/*--------------------------------------------------------------------------*/
/* ALBERTA:  an Adaptive multi Level finite element toolbox using           */
/*           Bisectioning refinement and Error control by Residual          */
/*           Techniques for scientific Applications                         */
/*                                                                          */
/* file:     bas_fct.c                                                      */
/*                                                                          */
/* description:  collecting information of all Lagrange elements            */
/*                                                                          */
/*--------------------------------------------------------------------------*/
/*                                                                          */
/*  authors:   Alfred Schmidt                                               */
/*             Zentrum fuer Technomathematik                                */
/*             Fachbereich 3 Mathematik/Informatik                          */
/*             Universitaet Bremen                                          */
/*             Bibliothekstr. 2                                             */
/*             D-28359 Bremen, Germany                                      */
/*                                                                          */
/*             Kunibert G. Siebert                                          */
/*             Institut fuer Mathematik                                     */
/*             Universitaet Augsburg                                        */
/*             Universitaetsstr. 14                                         */
/*             D-86159 Augsburg, Germany                                    */
/*                                                                          */
/*  http://www.mathematik.uni-freiburg.de/IAM/ALBERTA                       */
/*                                                                          */
/*  (c) by A. Schmidt and K.G. Siebert (1996-2003)                          */
/*                                                                          */
/*--------------------------------------------------------------------------*/

#include "alberta_intern.h"
#include "alberta.h"

/* Macro for a general scalar interpolation function for Lagrange basis
 * functions.
 *
 * This new version only allows "local" functions. The complexity of
 * parametric->init_element() etc. is moved to the high level code.
 *
 * If "wall >= 0" then the numbering of the basis function in the
 * returned coefficient array is according to BAS_FCTS::trace_dof_map.
 */
#define GENERATE_INTERPOL(PREFIX, DEGREE, DIM, N_BAS_FCT)		\
  static void PREFIX##interpol##DEGREE##_##DIM##d(			\
    EL_REAL_VEC *el_vec,						\
    const EL_INFO *el_info, int wall,					\
    int no, const int *b_no,						\
    LOC_FCT_AT_QP f, void *f_data,					\
    const BAS_FCTS *thisptr)						\
  {									\
    FUNCNAME(#PREFIX"interpol"#DEGREE"_"#DIM"d");			\
    LAGRANGE_DATA *ld = &lag_##DEGREE##_##DIM##d_data;			\
    REAL *rvec = el_vec->vec;						\
    const QUAD *lq;							\
    const int *trace_map;						\
    int i;								\
									\
    DEBUG_TEST_EXIT(ld->lumping_quad != NULL,				\
		    "called for uninitialized Lagrange basis functions\n"); \
									\
    if (wall < 0) {							\
      lq = ld->lumping_quad;						\
      trace_map = NULL;							\
    } else {								\
      int type = el_info->el_type > 0;					\
      int orient = el_info->orientation < 0;				\
      lq = &ld->trace_lumping_quad[type][orient][wall];			\
      trace_map = thisptr->trace_dof_map[type][orient][wall];		\
    }									\
									\
    DEBUG_TEST_EXIT(!b_no || (no >= 0 && no <= lq->n_points),		\
		    "not for %d points\n", no);				\
									\
    el_vec->n_components = thisptr->n_bas_fcts;				\
									\
    if (b_no) {								\
      for (i = 0; i < no; i++) {					\
	int ib = wall < 0 ? b_no[i] : trace_map[b_no[i]];		\
	rvec[ib] = f(el_info, lq, b_no[i], f_data);			\
      }									\
    } else {								\
      for (i = 0; i < lq->n_points; i++) {				\
	int ib = wall < 0 ? i : trace_map[i];				\
	rvec[ib] = f(el_info, lq, i, f_data);				\
      }									\
    }									\
  }									\
  struct _AI_semicolon_dummy

/* Macro for a general vector interpolation function (Lagrange basis fcts) */

#define GENERATE_INTERPOL_D(PREFIX, DEGREE, DIM, N_BAS_FCT)		\
  static void PREFIX##interpol_d_##DEGREE##_##DIM##d(			\
    EL_REAL_D_VEC *el_vec,						\
    const EL_INFO *el_info,						\
    int wall,								\
    int no, const int *b_no,						\
    LOC_FCT_D_AT_QP f, void *f_data,					\
    const BAS_FCTS *thisptr)						\
  {									\
    FUNCNAME("interpol_d"#DEGREE"_"#DIM"d");				\
    LAGRANGE_DATA *ld = &lag_##DEGREE##_##DIM##d_data;			\
    const QUAD *lq;							\
    REAL_D *rvec = el_vec->vec;						\
    const int *trace_map;						\
    int i;								\
									\
    DEBUG_TEST_EXIT(ld->lumping_quad != NULL,				\
		    "called for uninitialized Lagrange basis functions\n"); \
									\
    if (wall < 0) {							\
      lq = ld->lumping_quad;						\
      trace_map = NULL;							\
    } else {								\
      int type = el_info->el_type > 0;					\
      int orient = el_info->orientation < 0;				\
      lq = &ld->trace_lumping_quad[type][orient][wall];			\
      trace_map = thisptr->trace_dof_map[type][orient][wall];		\
    }									\
									\
    DEBUG_TEST_EXIT(!b_no || (no >= 0 && no <= lq->n_points),		\
		    "not for %d points\n", no);				\
									\
    el_vec->n_components = thisptr->n_bas_fcts;				\
									\
    if (b_no) {								\
      for (i = 0; i < no; i++) {					\
	int ib = wall < 0 ? b_no[i] : trace_map[b_no[i]];		\
	f(rvec[ib], el_info, lq, b_no[i], f_data);			\
      }									\
    } else {								\
      for (i = 0; i < lq->n_points; i++) {				\
	int ib = wall < 0 ? i : trace_map[i];				\
	f(rvec[ib], el_info, lq, i, f_data);				\
      }									\
    }									\
  }									\
  struct _AI_semicolon_dummy

/* Macro for a more general vector interpolation function (Lagrange
 * basis fcts _ONLY_).
 */

#define GENERATE_INTERPOL_DOW(PREFIX, DEGREE, DIM, N_BAS_FCT)		\
  static void PREFIX##interpol_dow_##DEGREE##_##DIM##d(			\
    EL_REAL_VEC_D *vec,							\
    const EL_INFO *el_info,						\
    int wall,								\
    int no, const int *b_no,						\
    LOC_FCT_D_AT_QP f, void *f_data,					\
    const BAS_FCTS *thisptr)						\
  {									\
    PREFIX##interpol_d_##DEGREE##_##DIM##d(				\
      (EL_REAL_D_VEC *)vec, el_info, wall, no, b_no, f, f_data, thisptr); \
  }									\
  struct _AI_semicolon_dummy

typedef struct lagrange_data {
  const REAL_B *nodes;        /* Lagrange nodes */
  const QUAD   *lumping_quad; /* Lumping quadrature on element ... */
  QUAD         trace_lumping_quad[2][2][N_WALLS_MAX]; /* ... and on walls */
} LAGRANGE_DATA;

typedef struct ortho_data {
  const QUAD_FAST *qfast; /* Quadrature for interpolation */
} ORTHO_DATA;

typedef const EL_REAL_VEC_D *
(*GET_REAL_VEC_D_TYPE)(REAL *, const EL *, const DOF_REAL_VEC_D *);

#define INIT_BFCTS_CHAIN(bstruct) CHAIN_INITIALIZER(bstruct), &bstruct

#define LAGRANGE_NAME(deg)      "lagrange"CPP_STRINGIZE(deg)
#define LAG_NAME_LEN(deg)       (sizeof(LAGRANGE_NAME(deg))-1)

#define DISC_LAGRANGE_NAME(deg) "disc_"LAGRANGE_NAME(deg)
#define DISC_LAG_NAME_LEN(deg)  (sizeof(DISC_LAGRANGE_NAME(deg))-1)

#define DISC_ORTHO_NAME(deg)     "disc_ortho_poly"CPP_STRINGIZE(deg)
#define DISC_ORTHO_NAME_LEN(deg) (sizeof(DISC_ORTHO_NAME(deg))-1)

#include "bas_fct_0d.c"
#include "bas_fct_1d.c"
#if DIM_MAX > 1
#include "bas_fct_2d.c"
#if DIM_MAX > 2
#include "bas_fct_3d.c"
#endif
#endif

#undef GENERATE_INTERPOL
#undef GENERATE_INTERPOL_D

typedef struct bfcts_node BFCTS_NODE;
struct bfcts_node
{
  const BAS_FCTS *bas_fcts;
  size_t         name_len;/* The length of the _relevant_ part of the name */
  BFCTS_NODE     *next;
};

const QUAD *lagrange_lumping_quadrature(const BAS_FCTS *bfcts)
{
  const QUAD *wq = get_quadrature(bfcts->dim, bfcts->degree);
  QUAD *lq;
  int ib, iq;
  REAL *lw; /* lumping weights */
  char *name;

  lq = MEM_CALLOC(1, QUAD);
  lq->w = lw = MEM_CALLOC(bfcts->n_bas_fcts, REAL);
  
  lq->name = name = MEM_ALLOC(sizeof("Lagrange X Xd Lumping Quadrature"), char);
  sprintf(name, "Lagrange %d %dd Lumping Quadrature",
	  bfcts->degree, bfcts->dim);
  
  lq->degree  = bfcts->degree;
  lq->dim     = bfcts->dim;
  lq->codim   = 0;
  lq->subsplx = -1;
  lq->n_points =
    lq->n_points_max = bfcts->n_bas_fcts;
  lq->lambda  = LAGRANGE_NODES(bfcts);
  lq->w       = lw;

  /* Now compute the weights using one sufficiently good quadrature
   * formula s.t. the integrals are exact for all basis functions (and
   * thus for the entire space of polynomials up to
   * bfcts->degree). This means that the weights are simply the
   * integral of the basis functions taken over the standard simplex.
   */
  for (ib = 0; ib < bfcts->n_bas_fcts; ib++) {
    for (iq = 0; iq < wq->n_points; iq++) {
      lw[ib] += wq->w[iq]*PHI(bfcts, ib, wq->lambda[iq]);
    }
  }

  /* Allocate the meta-data structure, but do not register the
   * quadrature for general use.
   */
  register_quadrature(lq);

  return lq;
}

/*******************************************************************************
 *  List of all discontinuous orthogonal basis functions.
 ******************************************************************************/
#define MAX_DEG 2
static BFCTS_NODE all_disc_ortho_poly[DIM_MAX+1][MAX_DEG] = {
  { { NULL, 0, NULL } },
#if DIM_MAX > 0 /* always */
  { { &disc_ortho1_1d, DISC_ORTHO_NAME_LEN(1), &all_disc_ortho_poly[1][1] },
    { &disc_ortho2_1d, DISC_ORTHO_NAME_LEN(2), NULL }, },
#endif
#if DIM_MAX > 1
  { { &disc_ortho1_2d, DISC_ORTHO_NAME_LEN(1), &all_disc_ortho_poly[2][1] },
    { &disc_ortho2_2d, DISC_ORTHO_NAME_LEN(2), NULL }, },
#endif 
#if DIM_MAX > 2
  { { &disc_ortho1_3d, DISC_ORTHO_NAME_LEN(1), &all_disc_ortho_poly[3][1] },
    { &disc_ortho2_3d, DISC_ORTHO_NAME_LEN(2), NULL }, },
#endif
};

const BAS_FCTS *get_disc_ortho_poly(int dim, int degree)
{
  FUNCNAME("get_disc_ortho_poly");
  const BAS_FCTS *bfcts;
  ORTHO_DATA *od;

  if ((dim < 0 || dim > DIM_MAX)) {
    ERROR("Discontinuous orthogonal basis functions of dimension %d are "
	  "not available for DIM_MAX == %d!\n", dim, DIM_MAX);
    return NULL;
  }

  if (degree < 0 || degree > MAX_DEG) {
    ERROR("Discontinuous orthogonal basis functions of degree %d are "
	  "not available\n", degree);
    return NULL;
  }

  if (dim == 0) {
    bfcts = get_lagrange(0, 4);
  } else if (degree == 0) {
    bfcts = get_lagrange(dim, degree);
  } else {
    bfcts = all_disc_ortho_poly[dim][degree-1].bas_fcts;
  }

  od = (ORTHO_DATA *)bfcts->ext_data;

  if (od->qfast == NULL) {
    od->qfast = get_quad_fast(bfcts, get_quadrature(dim, 2*degree), INIT_PHI);
  }

  return bfcts;
}

/*******************************************************************************
 *  List of all discontinuous Lagrange basisfunctions.
 ******************************************************************************/
#define MAX_DEG 2

static BFCTS_NODE all_disc_lagrange[DIM_MAX+1][MAX_DEG+1] = {
  { { NULL, 0, NULL } },
#if DIM_MAX > 0 /* always */
  { { &disc_lagrange0_1d, DISC_LAG_NAME_LEN(0), &all_disc_lagrange[1][1] },
    { &disc_lagrange1_1d, DISC_LAG_NAME_LEN(1), &all_disc_lagrange[1][2] },
    { &disc_lagrange2_1d, DISC_LAG_NAME_LEN(2), &all_disc_ortho_poly[1][0] }, },
#endif
#if DIM_MAX > 1
  { { &disc_lagrange0_2d, DISC_LAG_NAME_LEN(0), &all_disc_lagrange[2][1] },
    { &disc_lagrange1_2d, DISC_LAG_NAME_LEN(1), &all_disc_lagrange[2][2] },
    { &disc_lagrange2_2d, DISC_LAG_NAME_LEN(2), &all_disc_ortho_poly[2][0] }, },
#endif 
#if DIM_MAX > 2
  { { &disc_lagrange0_3d, DISC_LAG_NAME_LEN(0), &all_disc_lagrange[3][1] },
    { &disc_lagrange1_3d, DISC_LAG_NAME_LEN(1), &all_disc_lagrange[3][2] },
    { &disc_lagrange2_3d, DISC_LAG_NAME_LEN(2), &all_disc_ortho_poly[3][0] }, },
#endif
};

const BAS_FCTS *get_discontinuous_lagrange(int dim, int degree)
{
  FUNCNAME("get_discontinuous_lagrange");
  const BAS_FCTS *bfcts;
  LAGRANGE_DATA *ld, *tr_ld;

  if (dim < 0 || dim > DIM_MAX) {
    ERROR("Discontinuous Lagrange basis functions of dimension %d are "
	  "not available for DIM_MAX == %d!\n", dim, DIM_MAX);
    return NULL;
  }

  if (degree < 0 || degree > MAX_DEG) {
    ERROR("Discontinuous Lagrange basis functions of degree %d are "
	  "not available\n", degree);
    return NULL;
  }

  if (dim == 0) {
    bfcts = get_lagrange(0, 4);
  } else {
    bfcts = all_disc_lagrange[dim][degree].bas_fcts;
  }

  ld = (LAGRANGE_DATA *)bfcts->ext_data;
  if (ld->lumping_quad == NULL) {
    ld->lumping_quad = lagrange_lumping_quadrature(bfcts);
    if (dim >= 1) {
      REAL_B *lambda;
      QUAD *lq, *tlq;
      int o, t, w;
      /* recursively also initialize the trace-space quadratures. */
      get_discontinuous_lagrange(dim-1, degree);
      tr_ld = (LAGRANGE_DATA *)bfcts->trace_bas_fcts->ext_data;
      lq = (QUAD *)ld->lumping_quad;
      for (t = 0; t <= (dim > 2); t++) {
	for (o = 0; o <= (dim > 2); o++) {
	  for (w = 0; w < N_WALLS(dim); w++) {
	    tlq = &ld->trace_lumping_quad[t][o][w];
	    *tlq = *tr_ld->lumping_quad;
	    tlq->codim   = 1;
	    tlq->subsplx = w;
	    tlq->lambda = (const REAL_B *)
	      (lambda = MEM_CALLOC(tr_ld->lumping_quad->n_points, REAL_B));
	    if (degree == 0) {
	      /* Rather choose the mid-point on the respective wall;
	       * degree 0 is special in that there is -- in principle
	       * -- no well defined Lagrange-node.
	       */
	      int i;
	      for (i = 0; i < w; i++) {
		lambda[0][i] = 1.0/(REAL)N_LAMBDA(dim);
	      }
	      for (++i; i < N_LAMBDA(dim); i++) {
		lambda[0][i] = 1.0/(REAL)N_LAMBDA(dim);
	      }
	    } else {
	      int b;
	      for (b = 0; b < N_BAS_LAGRANGE(degree, dim-1); b++) {
		COPY_BAR(dim,
			 lq->lambda[bfcts->trace_dof_map[t][o][w][b]],
			 lambda[b]);
	      }
	    }
	  }
	}
      }
    }
  }

  return bfcts;
}

#undef MAX_DEG

/*--------------------------------------------------------------------------*/
/*  linked list of all used basis functions: Lagrange basisfunctions are    */
/*  always members of the list                                              */
/*--------------------------------------------------------------------------*/
#define MAX_DEG 4

static BFCTS_NODE all_lagrange[DIM_MAX+1][MAX_DEG+1] = {
#if DIM_MAX >= 0 /* ;) */
  { { &lagrange_0d, sizeof("lagrange")-1, NULL }, },
#endif
#if DIM_MAX >= 1
  { { &lagrange1_1d, LAG_NAME_LEN(1), &all_lagrange[1][1] },
    { &lagrange2_1d, LAG_NAME_LEN(2), &all_lagrange[1][2] },
    { &lagrange3_1d, LAG_NAME_LEN(3), &all_lagrange[1][3] },
    { &lagrange4_1d, LAG_NAME_LEN(4), &all_disc_lagrange[1][0] }, },
#endif
#if DIM_MAX >= 2
  { { &lagrange1_2d, LAG_NAME_LEN(1), &all_lagrange[2][1] },
    { &lagrange2_2d, LAG_NAME_LEN(2), &all_lagrange[2][2] },
    { &lagrange3_2d, LAG_NAME_LEN(3), &all_lagrange[2][3] },
    { &lagrange4_2d, LAG_NAME_LEN(4), &all_disc_lagrange[2][0] }, },
#endif
#if DIM_MAX >= 3
  { { &lagrange1_3d, LAG_NAME_LEN(1), &all_lagrange[3][1] },
    { &lagrange2_3d, LAG_NAME_LEN(2), &all_lagrange[3][2] },
    { &lagrange3_3d, LAG_NAME_LEN(3), &all_lagrange[3][3] },
    { &lagrange4_3d, LAG_NAME_LEN(4), &all_disc_lagrange[3][0] }, },
#endif
};

int n_bas_fcts_max[] = {
  N_BAS_LAG_0D,
  N_BAS_LAG_4_1D,
#if DIM_MAX > 1
  N_BAS_LAG_4_2D,
# if DIM_MAX > 2
  N_BAS_LAG_4_3D,
#  if DIM_MAX > 3
#   error FIXME!
#  endif
# endif
#endif
};

const BAS_FCTS *get_lagrange(int dim, int degree)
{
  FUNCNAME("get_lagrange");
  const BAS_FCTS *bfcts;
  LAGRANGE_DATA *ld, *tr_ld;

  if (degree == 0) {
    return get_discontinuous_lagrange(dim, degree);
  }

  if (dim < 0 || dim > DIM_MAX) {
#if ALBERTA_DEBUG
    WARNING("Lagrange basis functions of dimension %d are "
	  "not available for DIM_MAX == %d!\n", dim, DIM_MAX);
#endif
    return NULL;
  }

  if (degree < 1 || degree > MAX_DEG) {
#if ALBERTA_DEBUG
    WARNING("no lagrangian basis functions of degree %d\n", degree);
#endif
    return NULL;
  }

  if (dim == 0) {
    degree = 1;
  }

  bfcts = all_lagrange[dim][degree-1].bas_fcts;

  ld = (LAGRANGE_DATA *)bfcts->ext_data;
  if (ld->lumping_quad == NULL) {
    ld->lumping_quad = lagrange_lumping_quadrature(bfcts);
    if (dim >= 1) {
      REAL_B *lambda;
      QUAD *lq, *tlq;
      int o, t, w;
      /* recursively also initialize the trace-space quadratures. */
      get_lagrange(dim-1, degree);
      tr_ld = (LAGRANGE_DATA *)bfcts->trace_bas_fcts->ext_data;
      lq = (QUAD *)ld->lumping_quad;
      for (t = 0; t <= (dim > 2); t++) {
	for (o = 0; o <= (dim > 2); o++) {
	  for (w = 0; w < N_WALLS(dim); w++) {
	    tlq = &ld->trace_lumping_quad[t][o][w];
	    *tlq = *tr_ld->lumping_quad;
	    tlq->codim   = 1;
	    tlq->subsplx = w;
	    tlq->lambda = (const REAL_B *)
	      (lambda = MEM_CALLOC(tr_ld->lumping_quad->n_points, REAL_B));
	    if (degree == 0) {
	      /* Rather choose the mid-point on the respective wall;
	       * degree 0 is special in that there is -- in principle
	       * -- no well defined Lagrange-node.
	       */
	      int i;
	      for (i = 0; i < w; i++) {
		lambda[0][i] = 1.0/(REAL)N_LAMBDA(dim);
	      }
	      for (++i; i < N_LAMBDA(dim); i++) {
		lambda[0][i] = 1.0/(REAL)N_LAMBDA(dim);
	      }
	    } else {
	      int b;
	      for (b = 0; b < N_BAS_LAGRANGE(degree, dim-1); b++) {
		COPY_BAR(dim,
			 lq->lambda[bfcts->trace_dof_map[t][o][w][b]],
			 lambda[b]);
	      }
	    }
	  }
	}
      }
    }
  }

  return bfcts;
}

/* Default get_FOOBAR_vec() implementation */
#define EQ_COPY(src, dst) (dst) = (src)
#define DEFUN_GET_VEC(VECNAME, COPY)					\
  const EL_##VECNAME##_VEC *						\
  CPP_CONCAT3(default_get_, VECNAME##_name, _vec)(			\
    VECNAME##_VEC_TYPE *vec,						\
    const EL *el,							\
    const DOF_##VECNAME##_VEC *dof_vec)					\
  {									\
    FUNCNAME("get_"CPP_STRINGIZE(VECNAME##_name)"_vec");		\
    VECNAME##_VEC_TYPE *rvec = vec ? vec : dof_vec->vec_loc->vec;	\
    const BAS_FCTS *bas_fcts = dof_vec->fe_space->bas_fcts;		\
    int n_bas_fcts = bas_fcts->n_bas_fcts;				\
    DOF index[n_bas_fcts];						\
    int  i;								\
									\
    GET_DOF_INDICES(dof_vec->fe_space->bas_fcts,			\
		    el, dof_vec->fe_space->admin, index);		\
									\
    for (i = 0; i < n_bas_fcts; i++) {					\
      COPY(dof_vec->vec[index[i]], rvec[i]);				\
    }									\
    									\
    return vec ? NULL : dof_vec->vec_loc;				\
  }									\
  struct _AI_semicolon_dummy

DEFUN_GET_VEC(INT,     EQ_COPY);
DEFUN_GET_VEC(REAL,    EQ_COPY);
DEFUN_GET_VEC(REAL_D,  COPY_DOW);
DEFUN_GET_VEC(REAL_DD, _AI_MCOPY_DOW);
DEFUN_GET_VEC(UCHAR,   EQ_COPY);
DEFUN_GET_VEC(SCHAR,   EQ_COPY);
DEFUN_GET_VEC(PTR,     EQ_COPY);

const EL_REAL_VEC_D *
default_get_real_vec_d(REAL vec[],
		       const EL *el,
		       const DOF_REAL_VEC_D *dof_vec)
{
  if (dof_vec->stride != 1) {
    return (EL_REAL_VEC_D *)default_get_real_d_vec(
      (REAL_D *)vec, el, (const DOF_REAL_D_VEC *)dof_vec);    
  } else {
    return (EL_REAL_VEC_D *)default_get_real_vec(
      vec, el, (const DOF_REAL_VEC *)dof_vec);    
  }
}

/*--------------------------------------------------------------------------*/
/*  add a set of new basis functions to the list; return true, if possible  */
/*  else false                                                              */
/*--------------------------------------------------------------------------*/

static struct bfcts_node *bas_fcts_list[DIM_MAX+1] = {
#if DIM_MAX >= 0
  &all_lagrange[0][0],
#endif
#if DIM_MAX >= 1
  &all_lagrange[1][0],
#endif
#if DIM_MAX >= 2
  &all_lagrange[2][0],
#endif
#if DIM_MAX >= 3
  &all_lagrange[3][0],
#endif
};

/* The return value is the old definition, if basis-functions of the
 * same name already exist. The functions ignores an options _Xd
 * suffix (e.g.: "lagrange_3_2d", only the "lagrange_3" part of the
 * name is taken into account).
 */
const BAS_FCTS *new_bas_fcts(const BAS_FCTS * bas_fcts)
{
  FUNCNAME("new_bas_fcts");
  BFCTS_NODE *bf_node;
  char suffix[3] = { '_', 'X', 'd' };
  size_t len;
  int dim;

  if (!bas_fcts) {
    ERROR("no basis functions specified; bas_fcts pointer to NULL\n");
    return(0);
  }

  TEST_EXIT(bas_fcts->name,
       "new basis functions must have name; bas_fcts->name pointer to NULL\n");

  TEST_EXIT(strlen(bas_fcts->name),
	    "new basis functions must have a non empty name\n");
  TEST_EXIT(bas_fcts->dim >= 0 && bas_fcts->dim <= DIM_MAX,
	    "new basis functions must have a dimension between 1 and %d\n",
	    DIM_MAX);
  dim = bas_fcts->dim;
  if (dim >= 1) {
    TEST_EXIT(bas_fcts->trace_bas_fcts != NULL,
	      "new basis functions must define their trace-space.\n");
    new_bas_fcts(bas_fcts->trace_bas_fcts);
  }
  TEST_EXIT(bas_fcts->rdim == 1 || bas_fcts->rdim == DIM_OF_WORLD,
	    "Rand dimension must be either 1 or DIM_OF_WORLD.\n");
  TEST_EXIT(bas_fcts->degree >= 0,
	    "new basis functions must have a non negative quadrature degree\n");
  if (bas_fcts->n_bas_fcts > 0) { /* allow for the NULL space */
    TEST_EXIT(bas_fcts->phi,
	      "new basis functions: phi not set\n");
    TEST_EXIT(bas_fcts->grd_phi,
	      "new basis functions: grd_phi not set\n");
    TEST_EXIT(bas_fcts->rdim == 1 || bas_fcts->phi_d != NULL,
	      "new basis functions: rdim == DIM_OF_WORLD, "
	      "but phi_d == NULL.\n");
    TEST(bas_fcts->D2_phi,
	 "Warning: new basis functions: D2_phi not set\n");
  }
  TEST_EXIT(bas_fcts->get_dof_indices,
	    "new basis functions: get_dof_indices not set\n");
  TEST_EXIT(bas_fcts->get_bound,
	    "new basis functions: get_bound not set\n");
  if (bas_fcts->rdim == 1) {
    TEST(bas_fcts->interpol,
	 "Warning: new basis functions \"%s\":  interpol not set\n",
	 bas_fcts->name);
    TEST(bas_fcts->interpol_d,
	 "Warning: new basis functions \"%s\": interpol_d not set\n",
	 bas_fcts->name);
  }
  TEST(bas_fcts->interpol_dow,
       "Warning: new basis functions: interpol_dow not set\n");
    
  TEST_EXIT(bas_fcts->n_bas_fcts <= bas_fcts->n_bas_fcts_max,
	    "Error: n_bas_fcts must be < n_bas_fcts_max.\n");

  dim = bas_fcts->dim;
  suffix[1] = '0' + dim;
  len = strlen(bas_fcts->name);
  if (memcmp(bas_fcts->name+len-3, suffix, 3) == 0) {
    len -= 3; /* ignore the dimension part */
  }
  for (bf_node = bas_fcts_list[dim]; bf_node; bf_node = bf_node->next) {
    if (len == bf_node->name_len &&
	!strncmp(bas_fcts->name, bf_node->bas_fcts->name, len)) {
      const BAS_FCTS *old_bf = bf_node->bas_fcts;
      if (bas_fcts != old_bf) {
	WARNING("pointer to new and existing basis functions differ %p!=%p\n",
		bas_fcts, old_bf);
	WARNING("overriding old definition.\n");
      }      
      bf_node->bas_fcts = bas_fcts;
      return old_bf;
    }
  }

  bf_node = MEM_ALLOC(1, struct bfcts_node);
  bf_node->bas_fcts  = bas_fcts;
  bf_node->name_len  = len; /* length discarding the "_Xd" suffix */
  bf_node->next      = bas_fcts_list[dim];
  bas_fcts_list[dim] = bf_node;
  
  n_bas_fcts_max[dim] = MAX(n_bas_fcts_max[dim], bas_fcts->n_bas_fcts_max);

  return NULL; /* no old definition */
}

/*--------------------------------------------------------------------------*/
/*  get a pointer to a set of basis functions from the list; identifier is  */
/*  the name of the basis functions;                                        */
/*  returns a pointer to the BAS_FCTS structure if a corresponding set was  */
/*  found in the list, else pointer to NULL                                  */
/*--------------------------------------------------------------------------*/

#if HAVE_LIBLTDL && HAVE_LTDL_H
# include <ltdl.h>
#endif

#if 0
typedef struct bfcts_metadata 
{
  EL_DOF_VEC    *dof;
  EL_BNDRY_VEC  *bndry;
  EL_REAL_VEC   *coeff;
  EL_REAL_D_VEC *coeff_d;
  EL_INT_VEC    *int_vec;
  EL_REAL_VEC   *real_vec;
  EL_REAL_D_VEC *real_d_vec;
  EL_UCHAR_VEC  *uchar_vec;
  EL_SCHAR_VEC  *schar_vec;
  EL_PTR_VEC    *ptr_vec;
} BFCTS_METADATA;

/* Allocate a suitable meta-data object (storage for results etc.) */
const BFCTS_METADATA *get_bfcts_meta_data(const BAS_FCTS *bfcts)
{
  BFCTS_METADATA *md;
  
  md = MEM_ALLOC(1, BFCTS_METADATA);
  md->dof = get_el_dof_vec(bfcts);
  md->bndry = get_el_bndry_vec(bfcts);
  md->coeff = get_el_real_vec(bfcts);
  md->coeff_d = get_el_real_d_vec(bfcts);
  md->int_vec = get_el_int_vec(bfcts);
  md->real_vec = get_el_real_vec(bfcts);
  md->real_d_vec = get_el_real_d_vec(bfcts);
  md->uchar_vec = get_el_uchar_vec(bfcts);
  md->schar_vec = get_el_schar_vec(bfcts);
  md->ptr_vec = get_el_ptr_vec(bfcts);
}
#endif

#define BAS_FCTS_INIT_NAME "bas_fcts_init"

typedef struct bas_fcts_plugin BFCTS_PLUGIN;
struct bas_fcts_plugin 
{
  BAS_FCTS_INIT_FCT bas_fcts_init;
  BFCTS_PLUGIN   *next;
};

static BFCTS_PLUGIN *plugin_list;

void add_bas_fcts_plugin(BAS_FCTS_INIT_FCT init_fct)
{
  BFCTS_PLUGIN *plugin = MEM_ALLOC(1, BFCTS_PLUGIN);
  
  plugin->bas_fcts_init = init_fct;
  plugin->next = plugin_list;
  plugin_list  = plugin;
}

static void plugin_from_module(const char *dl_bas_fcts)
{
  FUNCNAME("plugin_from_module");
#if HAVE_LIBLTDL && HAVE_LTDL_H
  static bool init_done;
  lt_dlhandle dl_handle;
  BAS_FCTS_INIT_FCT init_fct;
  
  if (!init_done) {
    init_done = true;

    TEST_EXIT(lt_dlinit() == 0,
	      "Could not initialize libltdl (%s).\n", lt_dlerror);
  }
  if (dl_bas_fcts != NULL) {
    TEST_EXIT((dl_handle = lt_dlopenext(dl_bas_fcts)) != NULL,
	      "Could not dlopen \"%s\" (%s)\n", dl_bas_fcts, lt_dlerror());
    TEST_EXIT((init_fct = (BAS_FCTS_INIT_FCT)(unsigned long)
	       lt_dlsym(dl_handle, BAS_FCTS_INIT_NAME)) != NULL,
	      "Could not resolve \"%s\" (%s)\n",
	      BAS_FCTS_INIT_NAME, lt_dlerror());
    (void)lt_dlmakeresident(dl_handle);
    add_bas_fcts_plugin(init_fct);
  } else {
    if ((dl_handle = lt_dlopenext(dl_bas_fcts)) == NULL) {
      return;
    }
    if ((init_fct = (BAS_FCTS_INIT_FCT)(unsigned long)
	 lt_dlsym(dl_handle, BAS_FCTS_INIT_NAME)) == NULL) {
      return;
    }
    (void)lt_dlmakeresident(dl_handle);
    add_bas_fcts_plugin(init_fct);
  }
#else
  WARNING("No dynamic loading facilities available.\n");
#endif
}

/* Once-only initialization. We load any environment specified plugins
 * first, then we load the linked-in plugin (if defined).
 *
 * We search for plugins specified by the ALBERTA_BAS_FCTS_LIB_XD
 * environment variable, where X stands for DIM_OF_WORLD.
 */
static void plugin_init(void)
{
  static bool done;
  char *env_plugin;

  if (done) {
    return;
  }

  done = true;

#if ALBERTA_DEBUG
  env_plugin =
    getenv("ALBERTA_BAS_FCTS_LIB_"CPP_STRINGIZE(DIM_OF_WORLD)"D_DEBUG");
  MSG("Trying to load \"%s\"\n",
      "ALBERTA_BAS_FCTS_LIB_"CPP_STRINGIZE(DIM_OF_WORLD)"D_DEBUG");
#elif ALBERTA_PROFILE
  env_plugin =
    getenv("ALBERTA_BAS_FCTS_LIB_"CPP_STRINGIZE(DIM_OF_WORLD)"D_PROFILE");
  MSG("Trying to load \"%s\"\n",
      "ALBERTA_BAS_FCTS_LIB_"CPP_STRINGIZE(DIM_OF_WORLD)"D_PROFILE");
#else  
  env_plugin = getenv("ALBERTA_BAS_FCTS_LIB_"CPP_STRINGIZE(DIM_OF_WORLD)"D");
  MSG("Trying to load \"%s\"\n",
      "ALBERTA_BAS_FCTS_LIB_"CPP_STRINGIZE(DIM_OF_WORLD)"D");
#endif
  if (env_plugin) {
    plugin_from_module(env_plugin);
  }
  plugin_from_module(NULL); /* Search for linked-in module. */
}

const BAS_FCTS *get_bas_fcts(int dim, const char *name)
{
  FUNCNAME("get_bas_fcts");
  static bool initialized;
  const BAS_FCTS *bas_fcts;
  BFCTS_NODE *bfcts_node;
  BFCTS_PLUGIN *plug;
  size_t len;

  if (!initialized) {
    int dim, deg;

    for (dim = 0; dim <= DIM_MAX; dim++) {
      for (deg = 0; deg <= 4; deg++) {
	get_lagrange(dim, deg);
      }
      for (deg = 0; deg <= 2; deg++) {
	get_discontinuous_lagrange(dim, deg);
      }
      for (deg = 1; deg <= 2; deg++) {
	get_disc_ortho_poly(dim, deg);
      }
    }
    initialized = true;
  }

  if (!name) {
    ERROR("no name specified; cannot return pointer to basis functions\n");
    return NULL;
  }
  if ((len = strlen(name)) == 0) {
    ERROR("empty name; cannot return pointer to basis functions\n");
    return NULL;
  }
  /* discard the "_Xd" suffix */
  if (name[len-3] == '_' && name[len-2] == '0'+dim && name[len-1] == 'd') {
    len -= 3;
  }

  /* Special compatibility hack: in the course of proceeding to
   * ALBERTA-2 the p.w. constant Lagrange basis functions were renamed
   * to "disc_lagrange0".
   */
  if (strncmp(name, "lagrange0", len) == 0) {
    name = "disc_lagrange0";
    len += 5;
  }

  for (bfcts_node = bas_fcts_list[dim];
       bfcts_node; bfcts_node = bfcts_node->next) {
    if (len == bfcts_node->name_len &&
	!strncmp(bfcts_node->bas_fcts->name, name, len)) {
      return bfcts_node->bas_fcts;
    }
  }

  /* Not found: traverse the list of plugin-modules. */
  plugin_init();

  for (plug = plugin_list; plug != NULL; plug = plug->next) {
    if ((bas_fcts = plug->bas_fcts_init(dim, DIM_OF_WORLD, name)) != NULL) {
      new_bas_fcts(bas_fcts);
      return bas_fcts;
    }
  }

  ERROR("basis functions with name %s not found in list of all functions\n", name);
  return NULL;
}

/* Clone the set of basis-functions specified as "head", if tail !=
 * NULL, then add the copy of "head" as head to the list specified by
 * tail.
 *
 * Example:
 *
 * lagrange = get_lagrange(dim, degree);
 * bubble   = get_bas_fcts(dim, "Bubble");
 * bas_fcts = chain_bas_fcts(lagrange, chain_bas_fcts(bubble, NULL));
 * old_fcts = new_bas_fcts(bas_fcts);
 *
 * The chained basis functions will be added to the list of known
 * basis functions using the name
 *
 * "OWN_NAME#NEXT_NAME#NEXT_NEXT_NAME"
 *
 * During the construction of the name any "_Xd" suffixes are
 * discarded in order not to make the name too complicated. At the end
 * of the name-chain an appropriate "_Xd" suffix is added. The _Xd
 * suffixes are only for debugging, they are ignore everywhere else.
 *
 * A basis function chain is cyclic. The trace-spaces of the given
 * sets of basis functions are chained together accordingly.
 *
 * NOTE: this function does NOT call new_bas_fcts(); the caller has to
 * do so after constructing the desired chain.
 */
static
INIT_EL_TAG bfcts_chain_init_element(const EL_INFO *el_info, void *thisptr);

BAS_FCTS *chain_bas_fcts(const BAS_FCTS *head, BAS_FCTS *tail)
{
  FUNCNAME("chain_bas_fcts");
  BAS_FCTS *bfcts, *pos;
  FLAGS    fill_flags = head->fill_flags;
  char     *name;
  size_t   head_len = 0, tail_len = 0, len;
  bool     init_element_needed = false;
  int dim = head->dim;

  bfcts = MEM_ALLOC(1, BAS_FCTS);

  *bfcts             = *head;
  DBL_LIST_INIT(&bfcts->chain);
  bfcts->unchained   = head; /* remember the unchained instance */

  if ((tail && tail->init_element) || bfcts->init_element) {
    init_element_needed = true;
    if (tail != NULL) {
      fill_flags |= tail->fill_flags;
    }
    /* we need to install a proxy-initializer */
    INIT_ELEMENT_DEFUN(bfcts, bfcts_chain_init_element, fill_flags);
  }

  head_len = strlen(head->name);
  if (head->name[head_len-3] == '_' &&
      head->name[head_len-2] == '0'+dim &&
      head->name[head_len-1] == 'd') {
    head_len -= 3;
  }
  if (tail) {
    TEST_EXIT(dim == tail->dim,
	      "Trying to chain basis function with different dimensions.\n");
    tail_len = strlen(tail->name);
    if (tail->name[tail_len-3] == '_' &&
	tail->name[tail_len-2] == '0'+dim &&
	tail->name[tail_len-1] == 'd') {
      tail_len -= 3;
    }
  }
  
  len = head_len + (tail ? strlen("#") + tail_len : 0) + sizeof("_Xd");

  /* Use plain malloc() because of strdup() stuff */
  bfcts->name = name = (char *)malloc(len);
  sprintf(name, "%.*s%s%.*s_%dd",
	  (int)head_len, head->name,
	  tail ? "#" : "", (int)tail_len, tail ? tail->name : "",
	  dim);
  
  if (dim > 0) {
    TEST_EXIT(head->trace_bas_fcts != NULL &&
	      (tail == NULL || tail->trace_bas_fcts != NULL),
	       "Missing trace basis functions.\n");
    bfcts->trace_bas_fcts =
      chain_bas_fcts(head->trace_bas_fcts,
		     tail ? (BAS_FCTS *)tail->trace_bas_fcts : NULL);
  }

  if (tail) {
    /* Adjust names in cyclic list and add a copy of head to tail */
    CHAIN_ADD_TAIL(tail, bfcts);
    bfcts->degree = MAX(bfcts->degree, tail->degree);
    CHAIN_FOREACH(pos, bfcts, BAS_FCTS) {
      name = (char *)malloc(len);
      sprintf(name, "%.*s#%.*s_%dd",
	      (int)tail_len, pos->name, (int)head_len, head->name, dim);
      free((char *)pos->name);
      pos->name = name;
      if (init_element_needed) {
	/* we need to install a proxy-initializer */
	INIT_ELEMENT_DEFUN(pos, bfcts_chain_init_element, fill_flags);
      }
    }
  }

  return bfcts;
}

/* Chain initializer, walk the entire chain and initialize each
 * element in turn. This should be (algorithmically) the same as
 * qfast_chain_init_element().
 */
static INIT_EL_TAG
bfcts_chain_init_element(const EL_INFO *el_info, void *thisptr)
{
  BAS_FCTS       *bas_fcts = (BAS_FCTS *)thisptr;
  INIT_EL_TAG    chain_tag = INIT_EL_TAG_NONE;
  INIT_EL_TAG    old_tag;
  bool           new_tag = false;

  CHAIN_DO(bas_fcts, BAS_FCTS) {
    if (INIT_ELEMENT_NEEDED(bas_fcts->unchained)) {
      old_tag = INIT_EL_TAG_CTX_TAG(&bas_fcts->tag_ctx);
      chain_tag |= INIT_ELEMENT_SINGLE(el_info, bas_fcts);
      if (old_tag != INIT_EL_TAG_CTX_TAG(&bas_fcts->tag_ctx)) {
	new_tag = true;
      }
    } else {
      chain_tag |= INIT_EL_TAG_DFLT;
    }
  } CHAIN_WHILE(bas_fcts, BAS_FCTS);

  if (chain_tag == INIT_EL_TAG_NONE) {
    chain_tag = INIT_EL_TAG_DFLT;
  }
  if (chain_tag == INIT_EL_TAG_DFLT || chain_tag == INIT_EL_TAG_NULL) {
    return chain_tag;
  } else {
    if (new_tag) {
      INIT_EL_TAG_CTX_UNIQ(&bas_fcts->tag_ctx);
    }
    return INIT_EL_TAG_CTX_TAG(&bas_fcts->tag_ctx);
  }
}

