/*
 * MLMM.C - memory management routines for PML
 *
 * Source Version: 2.0
 * Software Release #92-0043
 *
 */

#include "cpyright.h"

#include "pml.h"

char
 *PM_AC_S              = "Arbitrarily-Connected",
 *PM_LR_S              = "Logical-Rectangular",
 *PM_MAP_INFO_P_S      = "PM_map_info *",
 *PM_MAPPING_P_S       = "PM_mapping *",
 *PM_SET_P_S           = "PM_set *",
 *PM_MAP_INFO_S        = "PM_map_info",
 *PM_MAPPING_S         = "PM_mapping",
 *PM_MESH_TOPOLOGY_S   = "PM_mesh_topology",
 *PM_MESH_TOPOLOGY_P_S = "PM_mesh_topology *",
 *PM_SET_S             = "PM_set";

static void
 SC_DECLARE(_PM_generate_coordinates, 
            (int n, int ne, int offs, double **elem,
	     int *maxes, REAL *extr));

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_MAKE_SET_ALT - given the name, shape, and elements of a set
 *                 - build the set structure and fill it
 */

PM_set *PM_make_set_alt(name, type, cp, nd, diml, nde, elml)
   char *name, *type;
   int cp, nd;
   int *diml;
   int nde;
   byte **elml;
   {int i, d, ne, *maxes;
    byte **elem;
    PM_set *set;

    maxes = FMAKE_N(int, nd, "PM_MAKE_SET:maxes");
    ne    = 1;
    for (i = 0; i < nd; i++)
        {d = diml[i];
	 maxes[i] = d;
         ne *= d;};

    elem = FMAKE_N(byte *, nde, "PM_MAKE_SET:elem");
    for (i = 0; i < nde; i++)
        elem[i] = elml[i];

    set = _PM_make_set(name, type, cp,
                       ne, nd, nde, maxes, elem, PM_REAL_Opers,
                       NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL);

    return(set);}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_MAKE_SET - given the name, shape, and elements of a set
 *             - build the set structure and fill it
 */

#ifdef PCC

PM_set *PM_make_set(name, type, cp, nd, va_alist)
   char *name, *type;
   int cp, nd;
   va_dcl

#endif

#ifdef ANSI

PM_set *PM_make_set(char *name, char *type, int cp, int nd, ...)

#endif

   {int i, d, ne, nde, *maxes;
    byte **elem;
    PM_set *set;

    SC_VA_START(nd);

    maxes = FMAKE_N(int, nd, "PM_MAKE_SET:maxes");
    ne    = 1;
    for (i = 0; i < nd; i++)
        {d = SC_VA_ARG(int);
         maxes[i] = d;
         ne *= d;};

    nde  = SC_VA_ARG(int);
    elem = FMAKE_N(byte *, nde, "PM_MAKE_SET:elem");
    for (i = 0; i < nde; i++)
        elem[i] = SC_VA_ARG(byte *);

    SC_VA_END;

    set = _PM_make_set(name, type, cp,
                       ne, nd, nde, maxes, elem, PM_REAL_Opers,
                       NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL);

    return(set);}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_MAKE_AC_SET - given the name, connectivity, and elements of a set
 *                - build the set structure and fill it
 */

#ifdef PCC

PM_set *PM_make_ac_set(name, type, cp, mt, nde, va_alist)
   char *name, *type;
   int cp;
   PM_mesh_topology *mt;
   int nde;
   va_dcl

#endif

#ifdef ANSI

PM_set *PM_make_ac_set(char *name, char *type, int cp,
		       PM_mesh_topology *mt, int nde, ...)

#endif

   {int i, nd, ne;
    byte **elem;
    PM_set *set;

    nd = mt->n_dimensions;
    ne = mt->n_cells[0];

    SC_VA_START(nde);

    elem = FMAKE_N(byte *, nde, "PM_MAKE_AC_SET:elem");
    for (i = 0; i < nde; i++)
        elem[i] = SC_VA_ARG(byte *);

    SC_VA_END;

    set = _PM_make_set(name, type, cp,
                       ne, nd, nde,
                       NULL, elem,
                       NULL, NULL, NULL, NULL,
		       PM_MESH_TOPOLOGY_P_S, mt,
		       NULL, NULL, NULL);

    return(set);}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* _PM_MAKE_SET - allocate and initialize a set in the most primitive
 *              - terms
 *              - return the set
 */

PM_set *_PM_make_set(name, type, cp, ne, nd, nde, maxes, elem, opers,
                     metric, symtype, sym, toptype, top, inftype, inf, next)
   char *name, *type;
   int cp;
   long ne;
   int nd, nde, *maxes;
   byte *elem;
   PM_field *opers;
   REAL *metric;
   char *symtype;
   byte *sym;
   char *toptype;
   byte *top;
   char *inftype;
   byte *inf;
   PM_set *next;
   {PM_set *set;
    char bf[MAXLINE];
    long bpi;
    pcons *info;

    if (inftype == NULL)
       inftype = SC_PCONS_P_S;

    info = (pcons *) inf;

    SC_CHANGE_VALUE_ALIST(info, int, SC_INTEGER_P_S, "COPY-MEMORY", cp);

    inf = (byte *) info;

/* build the set */
    set                 = FMAKE(PM_set, "_PM_MAKE_SET:set");
    set->name           = SC_strsavef(name, "char*:_PM_MAKE_SET:name");
    set->n_elements     = ne;
    set->dimension      = nd;
    set->dimension_elem = nde;
    set->max_index      = maxes;
    set->elements       = (byte *) elem;
    set->opers          = PM_REAL_Opers;
    set->metric         = metric;
    set->symmetry_type  = symtype;
    set->symmetry       = sym;
    set->topology_type  = toptype;
    set->topology       = top;
    set->info_type      = inftype;
    set->info           = inf;
    set->next           = next;

    strcpy(bf, type);
    strtok(bf, " *");
    if (strcmp(bf, SC_DOUBLE_S) == 0)
       {set->extrema = (byte *) FMAKE_N(double, 2*nde,
                                "_PM_MAKE_SET:extrema");
        set->scales  = (byte *) FMAKE_N(double, nd,
                                "_PM_MAKE_SET:scales");}

    else if (strcmp(bf, SC_FLOAT_S) == 0)
       {set->extrema = (byte *) FMAKE_N(float, 2*nde,
                                "_PM_MAKE_SET:extrema");
        set->scales  = (byte *) FMAKE_N(float, nd,
                                "_PM_MAKE_SET:scales");}

    else if (strcmp(bf, SC_LONG_S) == 0)
       {set->extrema = (byte *) FMAKE_N(long, 2*nde,
                                "_PM_MAKE_SET:extrema");
        set->scales  = (byte *) FMAKE_N(long, nd,
                                "_PM_MAKE_SET:scales");}

    else if (strcmp(bf, SC_INTEGER_S) == 0)
       {set->extrema = (byte *) FMAKE_N(int, 2*nde,
                                "_PM_MAKE_SET:extrema");
        set->scales  = (byte *) FMAKE_N(int, nd,
                                "_PM_MAKE_SET:scales");}

    else if (strcmp(bf, SC_SHORT_S) == 0)
       {set->extrema = (byte *) FMAKE_N(short, 2*nde,
                                "_PM_MAKE_SET:extrema");
        set->scales  = (byte *) FMAKE_N(short, nd,
                                "_PM_MAKE_SET:scales");}

    else if (strcmp(bf, SC_CHAR_S) == 0)
       {set->extrema = (byte *) FMAKE_N(char, 2*nde,
                                "_PM_MAKE_SET:extrema");
        set->scales  = (byte *) FMAKE_N(char, nd,
                                "_PM_MAKE_SET:scales");}

    else
       {set->extrema = NULL;
        set->scales  = NULL;};

    strcat(bf, " *");
    set->es_type = SC_strsavef(bf, "char*:_PM_MAKE_SET:type");

    strcat(bf, "*");
    set->element_type = SC_strsavef(bf, "char*:_PM_MAKE_SET:type");

/* if requested copy the incoming data */
    if (cp)
       {int i;
	byte *ov, *nv, **el;

	el  = (byte **) elem;
        bpi = SIZEOF(type);
	for (i = 0; i < nde; i++)
            {ov = el[i];
	     nv = SC_alloc_na(ne, bpi, "_PM_MAKE_SET:nv", FALSE);
	     memcpy(nv, ov, ne*bpi);
	     el[i] = nv;};};

    PM_find_extrema(set);

    return(set);}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_REL_SET - release the storage associated with a set */

void PM_rel_set(set, mfl)
   PM_set *set;
   int mfl;
   {pcons *inf;
    PM_mesh_topology *mt;

    if (set == NULL)
       return;

    SFREE(set->name);
    SFREE(set->element_type);
    SFREE(set->es_type);
    SFREE(set->max_index);

    if (set->topology_type != NULL)
       {if (strcmp(set->topology_type, PM_MESH_TOPOLOGY_P_S) == 0)
	   {mt = (PM_mesh_topology *) set->topology;
	    if (mt != NULL)
	       PM_rel_topology(mt);};};

    if (set->info_type != NULL)
       {if (strcmp(set->info_type, SC_PCONS_P_S) == 0)
	   {inf = (pcons *) set->info;
	    if (inf != NULL)
	       SC_free_alist(inf, 3);};};

    if (mfl)
       {int i, nde;
        byte **elem;

        nde  = set->dimension_elem;
	elem = (byte **) set->elements;
	for (i = 0; i < nde; i++)
	    {SFREE(elem[i]);};};

    SFREE(set->elements);

    SFREE(set->extrema);
    SFREE(set->scales);
    SFREE(set);

    return;}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_MAKE_TOPOLOGY - make a PM_mesh_topology */

PM_mesh_topology *PM_make_topology(nd, bnp, bnc, bnd)
   int nd;
   int *bnp, *bnc;
   long **bnd;
   {PM_mesh_topology *mt;

    mt  = FMAKE(PM_mesh_topology, "PM_MAKE_TOPOLOGY:mt");
    mt->n_dimensions   = nd;
    mt->n_bound_params = bnp;
    mt->n_cells        = bnc;
    mt->boundaries     = bnd;

    return(mt);}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_REL_TOPOLOGY - release the storage associated with a PM_mesh_topology */

void PM_rel_topology(mt)
   PM_mesh_topology *mt;
   {int id, nd;
    long **bnd;

    if (mt == NULL)
       return;

    bnd = mt->boundaries;

    nd = mt->n_dimensions;
    for (id = 0; id <= nd; id++)
        {SFREE(bnd[id]);};

    SFREE(mt->boundaries);
    SFREE(mt->n_bound_params);
    SFREE(mt->n_cells);
    SFREE(mt);

    return;}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_ARRAY_REAL - make a copy of an arbitrary type array that is all
 *               - type REAL
 */

REAL *PM_array_real(type, p, n, x)
   char *type;
   byte *p;
   int n;
   REAL *x;
   {char bf[MAXLINE], *mtype;

    strcpy(bf, type);
    mtype = strtok(bf, " *");

    CONVERT(SC_REAL_S, &x, mtype, p, n, FALSE);

    return(x);}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_FIND_EXTREMA - record the extrema of each of the element array
 *                 - of the given set
 *                 -
 *                 -  a[0]    = var_0_min
 *                 -  a[1]    = var_0_max
 *                 -          .
 *                 -          .
 *                 -          .
 *                 -  a[2n]   = var_n_min
 *                 -  a[2n+1] = var_n_max
 *                 -
 *                 - also find the mesh scales
 */

void PM_find_extrema(s)
   PM_set *s;
   {int i, j, nd, nde, ne, *maxes;
    byte **elem;
    REAL *x, val, xmn, xmx, *extr, *pe, *scales;
    char bf[MAXLINE], *mtype;

    ne = s->n_elements;
    if (ne == 0)
       return;

    strcpy(bf, s->element_type);
    mtype = strtok(bf, " *");

/* CONVERT requires these to be explicitly NULLed */
    nde    = s->dimension_elem;
    nd     = s->dimension;
       
/*
    extr   = NULL;
    scales = NULL;
    CONVERT(SC_REAL_S, &extr, mtype, s->extrema, 2*nde, FALSE);
    CONVERT(SC_REAL_S, &scales, mtype, s->scales, nd, FALSE);
*/
    extr   = FMAKE_N(REAL, 2*nde, "PM_FIND_EXTREMA:extr");
    scales = FMAKE_N(REAL, nd, "PM_FIND_EXTREMA:scales");

    elem = (byte **) s->elements;
    pe   = extr;
    for (i = 0; i < nde; i++)
        {x = NULL;
         CONVERT(SC_REAL_S, &x, mtype, elem[i], ne, FALSE);

         xmn =  HUGE_REAL;
         xmx = -HUGE_REAL;
         for (j = 0; j < ne; j++)
             {val = x[j];
              xmn = min(xmn, val);
              xmx = max(xmx, val);};
         *pe++ = xmn;
         *pe++ = xmx;

         SFREE(x);};

    if (nde == nd)
       {pe    = extr;
        maxes = s->max_index;
        if (maxes == NULL)
	   {double sc;

            sc = 1.0/POW((double) ne, (1.0/((double) nd)));
	    for (i = 0; i < nd; i++)
	        {xmn = *pe++;
		 xmx = *pe++;
		 scales[i] = sc*(xmx - xmn);};}
        else
	   for (i = 0; i < nd; i++)
	       {xmn = *pe++;
		xmx = *pe++;
		scales[i] = (xmx - xmn)/((REAL) (maxes[i] - 1));};};

    CONVERT(mtype, &s->extrema, SC_REAL_S, extr, 2*nde, FALSE);
    CONVERT(mtype, &s->scales, SC_REAL_S, scales, nd, FALSE);

    SFREE(extr);
    SFREE(scales);

    return;}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* _PM_FILL_CP_ARRAY - compute the values to fill the Cartesian product
 *                   - arrays of ELEM recursively
 *                   - NOTE: this must be type double!!!!!
 */

static void _PM_fill_cp_array(n, ne, offs, elem, sets)
   int n;
   long ne;
   int offs;
   REAL **elem;
   PM_set **sets;
   {long i, is, nx, ns;
    REAL *x, *xv, val;
    byte **el;
    PM_set *s;

    if (n < 0)
       return;

    s  = sets[n];
    nx = s->max_index[0];
    ns = ne/nx;
    x  = elem[n] + offs;

    el = (byte **) s->elements;

    xv = PM_array_real(s->element_type, el[0], nx, NULL);

    for (i = 0L; i < nx; i++)
        {val = xv[i];
         for (is = 0L; is < ns; is++)
             *x++ = val;
         _PM_fill_cp_array(n-1, ns, (int) (i*ns), elem, sets);};

    SFREE(xv);

    return;}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_MAKE_CP_DOMAIN - build a set suitable for
 *                   - use as the domain of a Logical-Rectangular mapping
 *                   - by constructing the Cartesian product of 1D
 *                   - sets
 */

PM_set *PM_make_cp_domain(name, type, nd, sets)
   char *name, *type;
   int nd;
   PM_set **sets;
   {int i, mx, *maxes;
    long ne;
    REAL **delem;
    PM_set *set, *s;

    maxes = FMAKE_N(int, nd, "PM_MAKE_CP_DOMAIN:maxes");

/* compute the number of points */
    ne = 1L; 
    for (i = 0; i < nd; i++)
        {s        = sets[i];
         mx       = s->max_index[0];
         maxes[i] = mx;
	 ne      *= mx;};

/* compute the components as doubles */
    delem = FMAKE_N(REAL *, nd, "PM_MAKE_CP_DOMAIN:delem");
    for (i = 0; i < nd; i++)
        delem[i] = FMAKE_N(REAL, ne, "PM_MAKE_CP_DOMAIN:delem[]");

    _PM_fill_cp_array(nd-1, ne, 0, delem, sets);

/* build the set */
    set = _PM_make_set(name, SC_DOUBLE_S, TRUE,
		       ne, nd, nd, maxes, delem, NULL,
                       NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL);

    return(set);}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* _PM_GENERATE_COORDINATES - compute the values of the coordinate arrays
 *                          - recursively
 *                          - NOTE: this must be type double!!!!!
 */

static void _PM_generate_coordinates(n, ne, offs, elem, maxes, extr)
   int n, ne, offs;
   double **elem;
   int *maxes;
   REAL *extr;
   {int i, is, nx, ns;
    double a, d, *x, val;

    if (n < 0)
       return;

    nx = maxes[n];
    ns = ne/nx;

    if (extr == NULL)
       {a = 1.0;
	d = 1.0;}
    else
       {a = extr[2*n];
	d = (extr[2*n + 1] - a)/((double) (nx - 1));};

    x = elem[n] + offs;

    for (i = 0; i < nx; i++)
        {val = a + i*d;
         for (is = 0; is < ns; is++)
             *x++ = val;
         _PM_generate_coordinates(n-1, ns, i*ns, elem, maxes, extr);};

    return;}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_MAKE_LR_DOMAIN - build a set suitable for
 *                   - use as the domain of a Logical-Rectangular mapping
 */

PM_set *PM_make_lr_domain(name, type, nd, nde, maxes, extrema)
   char *name, *type;
   int nd, nde, *maxes;
   REAL *extrema;
   {int i;
    long ne;
    double **delem;
    byte **elem;
    PM_set *set;

/* compute the number of points */
    ne = 1L; 
    for (i = 0; i < nd; i++)
        ne *= maxes[i];

/* compute the components as doubles */
    delem = FMAKE_N(double *, nde, "PM_MAKE_LR_DOMAIN:delem");
    for (i = 0; i < nde; i++)
        delem[i] = FMAKE_N(double, ne, "PM_MAKE_LR_DOMAIN:delem[]");

    _PM_generate_coordinates(nd-1, ne, 0, delem, maxes, extrema);

/* convert the components to the desired type */
    elem = FMAKE_N(byte *, nde, "PM_MAKE_LR_DOMAIN:elem");
    for (i = 0; i < nde; i++)
        {elem[i] = NULL;
         CONVERT(type, &elem[i], SC_DOUBLE_S, delem[i], ne, FALSE);};

    for (i = 0; i < nde; i++)
        SFREE(delem[i]);
    SFREE(delem);

/* build the set */
    set = _PM_make_set(name, type, TRUE, ne, nd, nde, maxes, elem, NULL,
                       NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL);

    return(set);}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_RESOLVE_TYPE - resolve the meaning of NTYP and return the 
 *                 - result in LTYP
 *                 - return TRUE iff there will be something to do
 */

int PM_resolve_type(ltyp, ntyp, btyp)
   char *ltyp, *ntyp, *btyp;
   {int ret;
    char type[MAXLINE], *t;

    ret = TRUE;
    if (strcmp(ntyp, "none") == 0)
       ret = FALSE;
       
    else if (strcmp(ntyp, "nearest") == 0)
       {strcpy(type, btyp);
	if (strchr(type, '*') == NULL)
	   t = type;
	else
	   t = SC_firsttok(type, " *\t\f\n\r");

	CONTAINER(ltyp, t);}

    else
       strcpy(ltyp, ntyp);

    return(ret);}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_PROMOTE_SET - promote the set data to be of type NTYP
 *                - free the original data if FLAG is TRUE
 */

void PM_promote_set(s, ntyp, flag)
   PM_set *s;
   char *ntyp;
   int flag;
   {int id, nd, nde;
    long ne;
    char otyp[MAXLINE], ltyp[MAXLINE], nelt[MAXLINE], nest[MAXLINE];
    char *elt, *est, *ot;
    byte **elem, *e;

    if (!PM_resolve_type(ltyp, ntyp, s->element_type))
       return;

    elt = s->element_type;
    est = s->es_type;
    strcpy(otyp, est);
    if (strchr(otyp, '*') == NULL)
       ot = otyp;
    else
       ot = SC_firsttok(otyp, " *\t\f\n\r");

    sprintf(nelt, "%s **", ltyp);
    sprintf(nest, "%s *", ltyp);

/* change the type names */
    SFREE(elt);
    SFREE(est);

    s->element_type = SC_strsavef(nelt, "char*:PM_PROMOTE_SET:nelt");
    s->es_type      = SC_strsavef(nest, "char*:PM_PROMOTE_SET:nest");

/* change the element data */
    ne   = s->n_elements;
    nde  = s->dimension_elem;
    elem = (byte **) s->elements;
    for (id = 0; id < nde; id++)
        {e        = elem[id];
	 elem[id] = NULL;

	 CONVERT(ltyp, &elem[id], ot, e, ne, flag);};

/* change the extrema/scale data */
    nd = s->dimension;

    e          = s->extrema;
    s->extrema = NULL;
    CONVERT(ltyp, &s->extrema, ot, e, 2*nd, TRUE);

    e         = s->scales;
    s->scales = NULL;
    CONVERT(ltyp, &s->scales, ot, e, nd, TRUE);

    return;}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_PROMOTE_ARRAY - promote the array data to be of type NTYP
 *                  - free the original data if FLAG is TRUE
 */

void PM_promote_array(a, ntyp, flag)
   C_array *a;
   char *ntyp;
   int flag;
   {long ne;
    char otyp[MAXLINE], ltyp[MAXLINE];
    char *elt;
    byte *data;

    elt = a->type;

    if (!PM_resolve_type(ltyp, ntyp, elt))
       return;

    if (strcmp(ltyp, elt) != 0)
       {strcpy(otyp, elt);

/* change the type name */
	SFREE(elt);

	a->type = SC_strsavef(ltyp, "char*:PM_PROMOTE_ARRAY:ltyp");

/* change the element data */
	ne      = a->length;
	data    = a->data;
	a->data = NULL;

	CONVERT(ltyp, &a->data, otyp, data, ne, flag);};

    return;}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_MAKE_MAPPING - given a domain, range, and attributes bind them
 *                 - all together in a freshly allocated PM_mapping
 *                 - and return a pointer to it
 */

PM_mapping *PM_make_mapping(name, cat, domain, range, centering, next)
   char *name, *cat;
   PM_set *domain, *range;
   int centering;
   PM_mapping *next;
   {int *pi;
    PM_mapping *f;
    pcons *inf;

/* build the map information */
    pi  = FMAKE(int, "PM_MAKE_MAPPING:pi");
    *pi = centering;
    inf = SC_add_alist(NULL, "CENTERING", "integer *", (byte *) pi);

/* build the mapping */
    f             = FMAKE(PM_mapping, "PM_MAKE_MAPPING:f");
    f->name       = SC_strsavef(name, "char*:PM_MAKE_MAPPING:name");
    f->category   = SC_strsavef(cat, "char*:PM_MAKE_MAPPING:cat");
    f->domain     = domain;
    f->range      = range;
    f->map_type   = SC_PCONS_P_S;
    f->map        = (byte *) inf;
    f->file_info  = NULL;
    f->file_type  = NO_FILE;
    f->file       = NULL;
    f->next       = next;

    return(f);}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_BUILD_GROTRIAN - take the data defining a grotrian diagram
 *                   - build and return a PM_mapping for it
 */

PM_mapping *PM_build_grotrian(name, type, cp,
                              xv, yv, labels, n_s, tr, up, low, n_tr)
   char *name, *type;
   int cp;
   byte *xv, *yv;
   char **labels;
   int n_s;
   byte *tr, *up, *low;
   int n_tr;
   {PM_mapping *pm;
    PM_set *domain, *range;

    domain = PM_make_set("Grotrian-Domain", type, cp,
                         1, n_s, 2, xv, yv);
    if (labels != NULL)
       {domain->info = (char *) labels;
        domain->info_type = SC_strsavef("char **",
                            "char*:PM_BUILD_GROTRIAN:type");};

    range  = PM_make_set("Transitions", type, cp,
                         1, n_tr, 3, tr, up, low);
    pm     = PM_make_mapping(name, "Grotrian-Diagram",
                             domain, range, N_CENT, NULL);

    return(pm);}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_REL_MAPPING - release the given mapping and its sets */

void PM_rel_mapping(f, rld, rlr)
   PM_mapping *f;
   int rld, rlr;
   {PM_map_info *mi;
    PM_mapping *nxt;

    if (f == NULL)
       return;

    mi = (PM_map_info *) f->map;

    if (f->domain != NULL)
       PM_rel_set(f->domain, rld);
    if (f->range != NULL)
       PM_rel_set(f->range, rlr);

    SFREE(f->name);
    SFREE(f->category);
    if (strcmp(f->map_type, SC_PCONS_P_S) == 0)
       SC_free_alist((pcons *) mi, 3);
    else
       SFREE(mi);

    nxt = f->next;
    if (nxt != NULL)
       PM_rel_mapping(nxt, rld, rlr);

    SFREE(f);

    return;}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_LR_AC_MESH_2D - map a 2D logical rectangular mesh section to an
 *                  - arbitrarily connected representation
 *                  - Arguments are:
 *                  -   (x, y)       arrays of x and y values
 *                  -   (kmax, lmax) logical extent of mesh
 *                  -   (k1, k2)     logical extent in k of desired section
 *                  -   (l1, l2)     logical extent in l of desired section
 *                  -   ord          number of boundary parameters to use
 */

PM_mesh_topology *PM_lr_ac_mesh_2d(px, py, kmax, lmax, k1, k2, l1, l2, ord)
   REAL **px, **py;
   int kmax, lmax, k1, k2, l1, l2, ord;
   {PM_mesh_topology *mt;
    int *nbp, *nc, ns, nz, nrz, nn, nrn;
    int in1, in2, ioc, icc, inc;
    int iz, in, fz, dkz, dkn, is, i, j, k, l;
    long **bnd, *ncell, *pcell;
    REAL *x, *y, *rx, *ry;

    dkz = k2 - k1;
    nrz = dkz*(l2 - l1);
    dkn = k2 - k1 + 1;
    nrn = dkn*(l2 - l1 + 1);

    nn = nrn;
    nz = nrz;
    fz = nrz;
    switch (ord)
       {case DEC_CELL_MAX  :
        case DEC_CELL_MIN  :
             ord = DEC_CELL_MAX;
             nz += 4*nrz;
             fz  = nrz;
             break;

        case CENTER_CELL   :
        case NGB_CELL      :
        case PARENT_CELL   :
        case OPPOSITE_CELL :
             break;

        case BND_CELL_MAX  :
        case BND_CELL_MIN  :
             ord = BND_CELL_MAX;
             break;};

    ord++;
    ns  = 4*nz;

/* setup new node arrays */
    x = FMAKE_N(REAL, nn, "PM_LR_AC_MESH_2D:x");
    y = FMAKE_N(REAL, nn, "PM_LR_AC_MESH_2D:y");

    rx = *px;
    ry = *py;
    for (l = l1; l <= l2; l++)
        for (k = k1; k <= k2; k++)
            {i    = (l - l1)*dkn + (k - k1);
             j    = (l - 1)*kmax + k - 1;
             x[i] = rx[j];
             y[i] = ry[j];};

/* allocate the boundary arrays */
    bnd = FMAKE_N(long *, 3, "PM_LR_AC_MESH_2D:bnd");
    bnd[2] = FMAKE_N(long, ord*nz, "PM_LR_AC_MESH_2D:bnd[2]");
    bnd[1] = FMAKE_N(long, ord*ns, "PM_LR_AC_MESH_2D:bnd[1]");
    bnd[0] = NULL;

/* fill the 2-cells */
    ncell = bnd[2];
    for (l = l1; l < l2; l++)
        for (k = k1; k < k2; k++)
            {iz    = (l - l1)*dkz + (k - k1);
             pcell = ncell + iz*ord;
             switch (ord-1)
                {case DEC_CELL_MAX  :
                 case DEC_CELL_MIN  :
                      pcell[DEC_CELL_MIN] = fz;
                      pcell[DEC_CELL_MAX] = fz + 3;
                      fz += 4;

                 case CENTER_CELL   :
                      pcell[CENTER_CELL] = -1;

                 case NGB_CELL      :
                      pcell[NGB_CELL] = -1;

                 case PARENT_CELL   :
                      pcell[PARENT_CELL] = -1;

                 case OPPOSITE_CELL :
                      pcell[OPPOSITE_CELL] = -1;

                 case BND_CELL_MAX  :
                 case BND_CELL_MIN  :
                      pcell[BND_CELL_MIN] = 4*iz;
                      pcell[BND_CELL_MAX] = 4*iz + 3;
                      break;};};

/* fill the 1-cells */
    in1   = 0;
    in2   = 0;
    ioc   = 0;
    inc   = 0;
    icc   = 0;
    ncell = bnd[1];
    for (l = l1; l < l2; l++)
        for (k = k1; k < k2; k++)
            {iz = (l - l1)*dkz + (k - k1);
             in = (l - l1)*dkn + (k - k1);
             for (i = 0; i < 4; i++)
                 {is    = 4*iz + i;
                  pcell = ncell + is*ord;
                  switch (i+1)
                     {case 1 :
                           in1 = in + 1;
                           in2 = in1 + dkn;
                           ioc = (k == k2-1) ? -1 : is + 6;
                           inc = iz + 1;
                           icc = -1;
			   break;

                      case 2 :
                           in1 = in + dkn + 1;
                           in2 = in1 - 1;
                           ioc = (l == l2-1) ? -1 : is + 2 + 4*(dkz - 1) + 4;
                           inc = iz + dkz;
                           icc = -1;
			   break;

                      case 3 :
                           in1 = in + dkn;
                           in2 = in1 - dkn;
                           ioc = (k == k1) ? -1 : is - 3 - 4*(dkz - 1) + 1;
                           inc = iz - 1;
                           icc = -1;
			   break;

                      case 4 :
                           in1 = in;
                           in2 = in1 + 1;
                           ioc = (l == l1) ? -1 : is - 3 - 4*dkz + 1;
                           inc = iz - dkz;
                           icc = -1;
                           break;};

                  switch (ord-1)
                     {case DEC_CELL_MAX  :
                      case DEC_CELL_MIN  :
                           pcell[DEC_CELL_MIN] = -1;
                           pcell[DEC_CELL_MAX] = -1;

                      case CENTER_CELL   :
                           pcell[CENTER_CELL] = icc;

                      case NGB_CELL      :
                           pcell[NGB_CELL] = inc;

                      case PARENT_CELL   :
                           pcell[PARENT_CELL] = iz;

                      case OPPOSITE_CELL :
                           pcell[OPPOSITE_CELL] = ioc;

                      case BND_CELL_MAX  :
                      case BND_CELL_MIN  :
                           pcell[BND_CELL_MIN] = in1;
                           pcell[BND_CELL_MAX] = in2;
                           break;};};};

/* setup the number of cells array */
    nc = FMAKE_N(int, 3, "PM_LR_AC_MESH_2D:nc");
    nc[0] = nn;
    nc[1] = ns;
    nc[2] = nz;

/* setup the number of boundary parameters array */
    nbp = FMAKE_N(int, 3, "PM_LR_AC_MESH_2D:nbp");
    nbp[0] = 1;
    nbp[1] = ord;
    nbp[2] = ord;

/* put it all together */
    mt = PM_make_topology(2, nbp, nc, bnd);

    *px = x;
    *py = y;

    return(mt);}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_MAPPING_INFO - extract any of the following information from
 *                 - a mapping
 */

#ifdef PCC

pcons *PM_mapping_info(h, va_alist)
   PM_mapping *h;
   va_dcl

#endif

#ifdef ANSI

pcons *PM_mapping_info(PM_mapping *h, ...)

#endif

   {int *pi, nc;
    double *pd;
    float *pf;
    char *pc, **ps, *name, bf[MAXLINE];
    pcons *map_alist, *asc;
    PM_map_info *hmap;

    if (h == NULL)
       return(NULL);

    if (h->map == NULL)
       return(NULL);

    SC_VA_START(h);

    if (strncmp(h->map_type, "PM_map_info", 11) == 0)
       {hmap = (PM_map_info *) (h->map);
	map_alist = NULL;}
    else if (strcmp(h->map_type, SC_PCONS_P_S) == 0)
       {map_alist = (pcons *) (h->map);
	hmap = NULL;}
    else
       return(NULL);

    while (TRUE)
       {name = SC_VA_ARG(char *);
        if (name == NULL)
           break;

        if (map_alist != NULL)
	   {for (asc = map_alist; asc != NULL; asc = (pcons *) asc->cdr)
	        if (strcmp((char *) ((pcons *) asc->car)->car, name) == 0)
		   {asc = (pcons *) asc->car;
		    break;};

            if (asc != NULL)
               {strcpy(bf, asc->cdr_type);
                nc = strlen(bf) - 1;
                if (bf[nc] == '*')
                   bf[nc] = '\0';

                if (strncmp(SC_INTEGER_S, bf, 3) == 0)
	           {pi  = SC_VA_ARG(int *);
                    *pi = *(int *) asc->cdr;}
                else if (strcmp(SC_STRING_S, bf) == 0)
	           {ps  = SC_VA_ARG(char **);
                    *ps = (char *) asc->cdr;}
                else if (strcmp(SC_DOUBLE_S, bf) == 0)
	           {pd  = SC_VA_ARG(double *);
                    *pd = *(double *) asc->cdr;}
                else if (strcmp(SC_FLOAT_S, bf) == 0)
	           {pf  = SC_VA_ARG(float *);
                    *pf = *(float *) asc->cdr;}
                else if (strcmp(SC_CHAR_S, bf) == 0)
	           {pc  = SC_VA_ARG(char *);
                    *pc = *(char *) asc->cdr;};};}

        else if ((hmap != NULL) && (strncmp(name, "CENTERING", 11) == 0))
	   {pi  = SC_VA_ARG(int *);
	    *pi = hmap->centering;};};

    SC_VA_END;

    return(map_alist);}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_GET_LIMITS - get the "LIMITS" property of the specified set */

REAL *PM_get_limits(s)
   PM_set *s;
   {REAL *extr;

    extr = NULL;
    if (s->info_type != NULL)
       if (strcmp(s->info_type, SC_PCONS_P_S) == 0)
	  SC_assoc_info((pcons *) s->info,
			"LIMITS", &extr,
			NULL);

    return(extr);}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_SET_LIMITS - set the "LIMITS" property of the specified set
 *               - assume that EXTR has been dynamically allocated
 *               - and can be released whenever it suits the library
 */

void PM_set_limits(s, extr)
   PM_set *s;
   REAL *extr;
   {pcons *inf, *data;

/* get the current list */
    if (s->info_type != NULL)
       {if (strcmp(s->info_type, SC_PCONS_P_S) == 0)
	   inf = (pcons *) s->info;

        else
	   inf = NULL;}
    else
       inf = NULL;

    data = SC_assoc_entry(inf, "LIMITS");

/* if there are no limits, remove any existing one
 * this does dom de and ran de
 */
    if (extr == NULL)
       {if (data != NULL)
           {inf = SC_rem_alist(inf, "LIMITS");
	    SC_rl_pcons(data, 3);};}

/* if it's there change it */
    else if (data != NULL)
       {SFREE(data->cdr);
	data->cdr = (byte *) extr;}

/* otherwise add it */
    else
       inf = SC_change_alist(inf, "LIMITS", SC_REAL_P_S, (byte *) extr);

    s->info_type = SC_PCONS_P_S;
    s->info      = (byte *) inf;

    return;}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/

/* PM_MAP_INFO_ALIST - convert PM_map_info data to an alist
 *                   -   int centering -> "CENTERING"
 */

pcons *PM_map_info_alist(ti)
   PM_map_info *ti;
   {pcons *inf;
    int *pi;

    inf = NULL;

    pi  = FMAKE(int, "PM_MAP_INFO_ALIST:pi");
    *pi = ti->centering;
    inf = SC_add_alist(inf, "CENTERING", "int *", (byte *) pi);

    return(inf);}

/*--------------------------------------------------------------------------*/
/*--------------------------------------------------------------------------*/
