/*
 * MLFIA.C - FORTRAN interface to PML
 *
 * Source Version: 2.0
 * Software Release #92-0043
 *
 */

#include "cpyright.h"

#include "pml.h"

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

/* PMSZFT - return the largest M such that 2^M <= N  */

FIXNUM F77_ID(pmszft_, pmszft, PMSZFT)(pn)
   FIXNUM *pn;
   {*pn = (FIXNUM) PM_next_exp_two((int) *pn);

    return((FIXNUM) TRUE);}

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

/* PMRFFT - perform an FFT on real data
 *        - this a wrapper for PM_fft_sc_real_data
 */

FIXNUM F77_ID(pmrfft_, pmrfft, PMRFFT)(outyr, outyi, outx, pn, inx, iny,
				       pxn, pxx, po)
   REAL *outyr, *outyi, *outx;
   FIXNUM *pn;
   REAL *inx, *iny, *pxn, *pxx;
   FIXNUM *po;
   {int i, n, np, ordr;
    double xmn, xmx;
    complex *cy;
    REAL *rx;

    n    = *pn;
    xmn  = *pxn;
    xmx  = *pxx;
    ordr = *po;

    if (!PM_fft_sc_real_data(&cy, &rx, inx, iny, n, xmn, xmx, ordr))
       return((FIXNUM) FALSE);

    np = n + 1;
    for (i = 0; i < np; i++)
        {outyr[i] = PM_REAL_C(cy[i]);
         outyi[i] = PM_IMAGINARY_C(cy[i]);
	 outx[i]  = rx[i];};

    SFREE(rx);
    SFREE(cy);

    return((FIXNUM) TRUE);}

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

/* PMCFFT - perform an FFT on complex data
 *        - this a wrapper for PM_fft_sc_complex_data
 */

FIXNUM F77_ID(pmcfft_, pmcfft, PMCFFT)(outyr, outyi, outx, pn,
				       inx, inyr, inyi,
				       pxn, pxx, pf, po)
   REAL *outyr, *outyi, *outx;
   FIXNUM *pn;
   REAL *inx, *inyr, *inyi, *pxn, *pxx;
   FIXNUM *pf, *po;
   {int i, n, np, flag, ordr;
    double xmn, xmx;
    complex *cy, *incy;
    REAL *rx;

    n    = *pn;
    xmn  = *pxn;
    xmx  = *pxx;
    flag = *pf;
    ordr = *po;

    incy = FMAKE_N(complex, n, "PMCFFT:incy");
    for (i = 0; i < n; i++)
        {PM_REAL_C(incy[i])      = inyr[i];
         PM_IMAGINARY_C(incy[i]) = inyi[i];};

    if (!PM_fft_sc_complex_data(&cy, &rx, inx, incy, n,
				xmn, xmx, flag, ordr))
       return((FIXNUM) FALSE);

    np = n + 1;
    for (i = 0; i < np; i++)
        {outyr[i] = PM_REAL_C(cy[i]);
         outyi[i] = PM_IMAGINARY_C(cy[i]);
	 outx[i]  = rx[i];};

    SFREE(rx);
    SFREE(cy);
    SFREE(incy);

    return((FIXNUM) TRUE);}

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

/* PMBSET - begin making a set */

FIXNUM F77_ID(pmbset_, pmbset, PMBSET)(pn, fname, pt, ftype,
				       pcp, pnd, pnde, pmx, ptp, inxt)
   FIXNUM *pn;
   F77_string fname;
   FIXNUM *pt;
   F77_string ftype;
   FIXNUM *pcp, *pnd, *pnde, *pmx, *ptp, *inxt;
   {int i, cp, nd, nde, *maxes;
    long ne, tp, d;
    char name[MAXLINE], type[MAXLINE], bf[MAXLINE], *topt, *s;
    byte **elem;
    pcons *info;
    PM_set *set, *next;
    PM_mesh_topology *top;

    SC_FORTRAN_STR_C(name, fname, *pn);
    SC_FORTRAN_STR_C(type, ftype, *pt);

    next = SC_GET_POINTER(PM_set, *inxt);
    cp   = *pcp;
    nd   = *pnd;
    nde  = *pnde;
    tp   = *ptp;

    if (tp == -1)
       {maxes = FMAKE_N(int, nd, "PMBSET:maxes");
	ne    = 1L;
        for (i = 0; i < nd; i++)
	    {d = pmx[i];
	     maxes[i] = d;
	     ne *= d;};
        topt = NULL;
	top  = NULL;}

    else
       {topt  = PM_MESH_TOPOLOGY_P_S;
        top   = SC_GET_POINTER(PM_mesh_topology, *ptp);
	maxes = NULL;
        ne    = top->n_cells[0];};

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

    elem = FMAKE_N(byte *, nde, "PMBSET:elem");

/* build the set */
    set                 = FMAKE(PM_set, "PMBSET:set");
    set->name           = SC_strsavef(name, "char*:PMBSET:name");
    set->n_elements     = ne;
    set->dimension      = nd;
    set->dimension_elem = nde;
    set->max_index      = maxes;
    set->elements       = (byte *) elem;
    set->opers          = NULL;
    set->metric         = NULL;
    set->symmetry_type  = NULL;
    set->symmetry       = NULL;
    set->topology_type  = topt;
    set->topology       = (byte *) top;
    set->info_type      = SC_PCONS_P_S;
    set->info           = (byte *) info;
    set->next           = next;
    
    strcpy(bf, type);
    SC_strtok(bf, " *", s);
    if (strcmp(bf, SC_DOUBLE_S) == 0)
       {set->extrema = (byte *) FMAKE_N(double, 2*nde,
                                "PMBSET:extrema");
        set->scales  = (byte *) FMAKE_N(double, nd,
                                "PMBSET:scales");}

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

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

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

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

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

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

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

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

    if (set == NULL)
       return(-1);

    else
       return((FIXNUM) SC_ADD_POINTER(set));}

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

/* PMESET - complete making a set */

FIXNUM F77_ID(pmeset_, pmeset, PMESET)(iset)
   FIXNUM *iset;
   {PM_set *set;

    set = SC_GET_POINTER(PM_set, *iset);

    PM_find_extrema(set);

    return((FIXNUM) TRUE);}

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

/* PMASET - add a component to a set */

FIXNUM F77_ID(pmaset_, pmaset, PMASET)(iset, pie, px)
   FIXNUM *iset, *pie;
   byte *px;
   {int ie, cp;
    pcons *info;
    byte **elem;
    PM_set *set;
    char *s;

    set  = SC_GET_POINTER(PM_set, *iset);
    ie   = *pie - 1;
    elem = (byte **) set->elements;
    info = (pcons *) set->info;
    SC_assoc_info(info,
		  "COPY-MEMORY", &cp,
		  NULL);

/* if requested copy the incoming data */
    if (cp)
       {int bpi;
        long ne;
	byte *nv;
        char bf[MAXLINE], *type;

	strcpy(bf, set->es_type);
	type = SC_strtok(bf, " *", s);
        bpi  = SIZEOF(type);
	ne   = set->n_elements;

	elem[ie] = nv = SC_alloc_na(ne, bpi, "PMASET:nv", FALSE);
	memcpy(nv, px, ne*bpi);}

    else
       elem[ie] = px;

    return((FIXNUM) TRUE);}

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

/* PMMTOP - make a PM_mesh_topology */

FIXNUM F77_ID(pmmtop_, pmmtop, PMMTOP)(pnd, pnc, pbp, pbnd)
   FIXNUM *pnd, *pnc, *pbp, *pbnd;
   {int i, j, n, nd, ndp;
    int *nc, *nbp;
    long **bnd, *pbd;
    FIXNUM *pbs;
    PM_mesh_topology *mt;
    
    nd  = *pnd;
    ndp = nd + 1;

/* setup the number of cells array */
    nc = FMAKE_N(int, ndp, "PMMTOP:nc");
    for (i = 0; i < ndp; i++)
        nc[i] = pnc[i];

/* setup the number of boundary parameters array */
    nbp = FMAKE_N(int, ndp, "PMMTOP:nbp");
    for (i = 0; i < ndp; i++)
        nbp[i] = pbp[i];

    pbs = pbnd;
    bnd = FMAKE_N(long *, ndp, "PMMTOP:bnd");
    for (i = 1; i < ndp; i++)
        {n = nbp[i]*nc[i];

	 bnd[i] = FMAKE_N(long, n, "PMMTOP:bnd[]");

         pbd = bnd[i];
	 for (j = 0; j < n; j++)
	     *pbd++ = *pbs++;};

    bnd[0] = NULL;

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

    if (mt == NULL)
       return(-1);

    else
       return((FIXNUM) SC_ADD_POINTER(mt));}

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