/*
 * PANTH.C - time history data collection for PANACEA
 *         - aims:
 *         -      (1) Portability of interface and data
 *         -      (2) C and FORTRAN API
 *         -      (3) Easy to use but flexible
 *         -      (4) Must be able to manager file familes
 *         -      (5) Must be able to restart from any "time"
 *         -          in a run (controlled by instance index
 *         -          maintained by the application)
 *         -      (6) Work with supplied transposer to ULTRA
 *
 * Source Version: 7.0
 * Software Release #92-0043
 *
 */

#include "cpyright.h"

#include "panace.h"

typedef struct s_th_info th_info;

struct s_th_info
   {PDBfile *file;
    int rec_count;};

typedef struct s_th_record th_record;

struct s_th_record
   {int n_members;
    char **members;
    char **labels;
    char *type;
    char *entry_name;};

typedef struct s_f77_th_record f77_th_record;

struct s_f77_th_record
   {char **labels;
    int n_labels;
    int n_labels_max;
    char **members;
    int n_members;
    int n_members_max;
    char *type;
    char *entry_name;};

static int
 *n_crv = NULL,
 n_domains;

int
 _PA_ul_print_flag = FALSE;

static dimdes
 *n_dpt = NULL;

static PDBfile
 **uf;

static th_record
 *th_data;

char
 PA_err[MAXLINE];

static char
 *HETEROGENEOUS = "heterogeneous";

static int
 SC_DECLARE(_PA_setup_uf_family,
         (char *name, char **thfiles, int nthf,
          int ncpf, int flag)),
 SC_DECLARE(_PA_transpose_stripe,
         (PDBfile *file, REAL **crve, char *stripe,
          char *type, char *mix, int na, int nrd)),
 SC_DECLARE(_PA_proc_rec,
         (char *name, PDBfile *th, int ncpf, int recn));

static syment
 SC_DECLARE(*_PA_truncate_entry, (PDBfile *file, char *name, long indx));

static char
 SC_DECLARE(*_PA_type_mix, (PDBfile *file, char *type));

static void
 SC_DECLARE(_PA_rl_th, (th_record *thd, int nthd));

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

/* PA_TH_OPEN - start a time history file family */

PDBfile *PA_th_open(name, mode, size, prev)
   char *name, *mode;
   long size;
   char *prev;
   {PDBfile *file;

    file = PD_open(name, mode);
    if (file != NULL)
       {if (size == 0L)
           PD_set_max_file_size(file, LONG_MAX);
        else
           PD_set_max_file_size(file, size);

        if (prev != NULL)
           file->previous_file = SC_strsavef(prev,
					     "char*:PA_TH_OPEN:file");};

    return(file);}

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

/* PA_TH_FAMILY - advance to the next member of the
 *              - time history file family
 */

PDBfile *PA_th_family(file)
   PDBfile *file;
   {PDBfile *nf;
    char bf[MAXLINE];
    int i, count;
    th_record thd;
    syment *ep;

    nf = PD_family(file, FALSE);

    if (nf != file)
       {for (i = 0; TRUE; i++)
            {sprintf(bf, "th%d", i);
             ep = PD_inquire_entry(file, bf, FALSE, NULL);
             if (ep == NULL)
                break;

	     PD_reset_ptr_list(file);
	     PD_reset_ptr_list(nf);

             if (!PD_read(file, bf, &thd))
                break;

             PD_write(nf, bf, "th_record", &thd);

	     _PA_rl_th(&thd, 1);};

        count = 0;
        PD_read(file, "n_types", &count);
        PD_write(nf, "n_types", SC_INTEGER_S, &count);

        PD_close(file);
        return(nf);}

    else
       return(file);}

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

/* PA_TH_DEF_REC - define a struct that matches a particular data stripe
 *               - since different groups of plots can have different
 *               - plotting frequencies, define one struct for each group
 *               - and this will match the data stripe for that group
 *               - A variable of type th_record will be written out for
 *               - each time domain defined.  It contains the type, member
 *               - names, labels, and name of the time domain struct data.
 *               - The library names these "thddd" starting from 0 and
 *               - strictly in order of the calls to this function
 *               -
 *               - Arguments:
 *               -   NAME    - name of the data entry
 *               -   TYPE    - name of the struct defining the time domain
 *               -   NMEMB   - number of members of the time domain struct
 *               -   MEMBERS - the names of the members of the time
 *               -             domain struct
 *               -   LABELS  - the labels for the curves associated with
 *               -           - the time domain (one less than NMEMB in
 *               -           - length) - this is optional and if not
 *               -           - provided labels will be constructed from
 *               -           - the member names
 */

defstr *PA_th_def_rec(file, name, type, nmemb, members, labels)
   PDBfile *file;
   char *name, *type;
   int nmemb;
   char **members, **labels;
   {int i, n, count;
    char bf[MAXLINE], **lbls, **mbrs, *ltyp;
    defstr *dp;
    th_record ht;

#ifdef SUNMOS

    count = 0;
    if (PD_inquire_entry(file, "n_types", TRUE, NULL) != NULL)
       PD_read(file, "n_types", &count);

#else

    if (!PD_read(file, "n_types", &count))
       count = 0;

#endif

    n    = nmemb - 1;
    lbls = FMAKE_N(char *, n, "PA_TH_DEF_REC:lbls");

    if (labels != NULL)
       {for (i = 0; i < n; i++)
            {if (labels[i] == NULL)
                sprintf(bf, "%s vs %s", members[i+1], members[0]);
             else
                sprintf(bf, "%s", labels[i]);
             lbls[i] = SC_strsavef(bf, "char*:PA_TH_DEF_REC:lbls[i]");};}

    else
       {for (i = 0; i < n; i++)
            {sprintf(bf, "%s vs %s", members[i+1], members[0]);
             lbls[i] = SC_strsavef(bf, "char*:PA_TH_DEF_REC:lbls[i]");};};

/* process the members to make them legal for PDB */
    mbrs = FMAKE_N(char *, nmemb, "PA_TH_DEF_REC:mbrs");
    for (i = 0; i < nmemb; i++)
        {ltyp = _PD_member_base_type(members[i]);
         dp = PD_inquire_type(file, ltyp);
         SFREE(ltyp);

         if (dp == NULL)
            {sprintf(bf, "double %s", members[i]);
             mbrs[i] = SC_strsavef(bf, "char*:PA_TH_DEF_REC:mbrs[i]");}
         else
            mbrs[i] = SC_strsavef(members[i], "char*:PA_TH_DEF_REC:mbrs[i]");};

/* define the th_record type if necessary */
    dp = PD_inquire_type(file, "th_record");
    if (dp == NULL)
       {PD_defstr(file, "th_record",
                  "integer n_members",
                  "char **members",
                  "char **labels",
                  "char *type",
                  "char *entry_name",
                  LAST);};

/* write the th_record for this type */
    ht.n_members  = nmemb;
    ht.members    = mbrs;
    ht.labels     = lbls;
    ht.type       = SC_strsavef(type, "char*:PA_TH_DEF_REC:type");
    ht.entry_name = SC_strsavef(name, "char*:PA_TH_DEF_REC:name");

    sprintf(bf, "th%d", count++);
    PD_write(file, bf, "th_record", &ht);

    SFREE(ht.type);
    SFREE(ht.entry_name);

/* define the type */
    dp = PD_defstr_alt(file, type, nmemb, mbrs);

/* update the counter */
    PD_write(file, "n_types", SC_INTEGER_S, &count);

/* reset the pointer lists */
    PD_reset_ptr_list(file);

/* free the labels */
    for (i = 0; i < n; i++)
        SFREE(lbls[i]);
    SFREE(lbls);

/* free the members */
    for (i = 0; i < nmemb; i++)
        SFREE(mbrs[i]);
    SFREE(mbrs);

    return(dp);}

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

/* PA_TH_WRITE - write time history data
 *             -
 *             - Arguments:
 *             -   NAME - time domain data entry name (data appended after
 *             -          first call
 *             -   TYPE - time domain struct name
 *             -   INST - instance index (starting index in a linear array
 *             -          of records for this block of records)
 *             -   NR   - number of records in this block
 *             -   VR   - the data which must be NR*sizeof(<TYPE>) long
 */

int PA_th_write(strm, name, type, inst, nr, vr)
   PDBfile *strm;
   char *name, *type;
   int inst, nr;
   byte *vr;
   {long nd, ind[3];
    int ret;
    syment *ep;

    switch (setjmp(_PD_write_err))
       {case ABORT    : return(FALSE);
        case ERR_FREE : return(TRUE);
        default       : memset(PD_err, 0, MAXLINE);
                        break;};

    ep = _PA_truncate_entry(strm, name, inst);
    if (ep == NULL)
       {nd = 1;
        ind[0] = inst;
        ind[1] = inst + nr - 1;
        ind[2] = 1L;

/* for time history data name and type are the same */
        ret = PD_write_alt(strm, name, type, vr, nd, ind);}

    else
       {nd = 1;
        ind[0] = inst;
        ind[1] = inst + nr - 1;
        ind[2] = 1L;
        ret = PD_append_alt(strm, name, vr, nd, ind);};

    PD_reset_ptr_list(strm);

    return(ret);}

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

/* PA_TH_WR_MEMBER - write time history data
 *                 -
 *                 - Arguments:
 *                 -   NAME   - time domain data entry name (data appended
 *                 -            after first call
 *                 -   MEMBER - time domain data entry name (data appended
 *                 -            after first call
 *                 -   TYPE - time domain struct name
 *                 -   INST - instance index (starting index in a linear
 *                 -          array of records for this block of records)
 *                 -   VR   - the data which must be NR*sizeof(<TYPE>) long
 */

int PA_th_wr_member(strm, name, member, type, inst, vr)
   PDBfile *strm;
   char *name, *member, *type;
   int inst;
   byte *vr;
   {int ret;
    char lname[MAXLINE], *mtype, *ltype;
    syment *ep;
    defstr *dp;
    memdes *desc;

    switch (setjmp(_PD_write_err))
       {case ABORT    : return(FALSE);
        case ERR_FREE : return(TRUE);
        default       : memset(PD_err, 0, MAXLINE);
                        break;};

    sprintf(lname, "%s[%d:%d].%s", name, inst, inst, member);

    mtype = _PD_member_base_type(type);
    dp    = PD_inquire_type(strm, mtype);
    if (dp == NULL)
       PD_error("CAN'T FIND TYPE - PA_TH_WR_MEMBER", PD_WRITE);
    SFREE(mtype);

    for (desc = dp->members; desc != NULL; desc = desc->next)
        {if ((strcmp(desc->name, member) == 0) ||
	    (strcmp(desc->member, member) == 0))
	   {ltype = desc->type;
	    break;};};

    if (ltype == NULL)
       PD_error("CAN'T FIND MEMBER TYPE - PA_TH_WR_MEMBER", PD_WRITE);

    ep = PD_inquire_entry(strm, name, FALSE, NULL);
    if (ep != NULL)
       {dimdes *od, *odims;

        odims = PD_entry_dimensions(ep);

/* check the dimensions for consistency */
	if (strm->major_order == COLUMN_MAJOR_ORDER)
	   for (od = odims; od->next != NULL; od = od->next);

	else if (strm->major_order == ROW_MAJOR_ORDER)
	   od = odims;

	if ((od->index_min <= inst) && (inst <= od->index_max))
           ret = PD_write(strm, lname, ltype, vr);

        else if (od->index_max < inst)
	   ret = PD_append(strm, lname, vr);

        else
	   PD_error("ILLEGAL INDEX - PA_TH_WR_MEMBER", PD_WRITE);}

    else
       ret = PD_write(strm, lname, ltype, vr);

    PD_reset_ptr_list(strm);

    return(ret);}

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

/* _PA_TRUNCATE_ENTRY - truncate the named entry to the specified size
 *                    - in the slowest varying dimension
 *                    - return the new, truncated syment
 */

static syment *_PA_truncate_entry(file, name, indx)
   PDBfile *file;
   char *name;
   long indx;
   {syment *ep;
    dimdes *odims, *od;
    symblock *sp;
    long i, n, numb, pags, enmb, bnmb, dlen;

    ep = PD_inquire_entry(file, name, FALSE, NULL);
    if (ep == NULL)
       return(NULL);

    odims = PD_entry_dimensions(ep);

/* check the dimensions for consistency */
    if (file->major_order == COLUMN_MAJOR_ORDER)
       for (od = odims; od->next != NULL; od = od->next);

    else if (file->major_order == ROW_MAJOR_ORDER)
       od = odims;

    if (indx < od->index_min)
       PD_error("INSTANCE INDEX LESS THAN MINIMUM - _PA_TRUNCATE_ENTRY",
		PD_WRITE);

    if (indx <= od->index_max)
       {numb = PD_entry_number(ep);
        dlen = od->index_max - od->index_min + 1L;
        pags = numb/dlen;
        enmb = (indx - od->index_min)*pags;

/* fix the dimensions (the instance index is 1 based reguardless of the
 * PDB API being used
 */
        od->index_max = indx - 1;
        od->number    = od->index_max - od->index_min + 1L;

/* if we're going back to the beginning, delete the entry */
        if (enmb == 0)
           {char path[MAXLINE];
	    hashel *hp;
	    HASHTAB *symt;

	    symt = file->symtab;

	    hp = PD_inquire_symbol(file, name, TRUE, path, symt);
	    _PD_rl_syment(ep);

/* purify complains of free memory read
 * if hp->def not nulled before SC_hash_rem
 */
	    hp->def = NULL;
            SC_hash_rem(path, symt);

            return(NULL);}

/* fix the blocks */
        else
           {sp = PD_entry_blocks(ep);
            n  = PD_n_blocks(ep);
            PD_entry_number(ep) = enmb;
            for (i = 0L; i < n; i++, enmb -= bnmb)
                {bnmb = sp[i].number;
                 if (enmb <= bnmb)
                    {sp[i].number = enmb;
                     REMAKE_N(sp, symblock, i+1);
		     PD_entry_blocks(ep) = sp;
                     break;};};};};

    return(ep);}

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

/* PA_TH_WR_IATTR - write instance attribute values
 *                -
 *                - Arguments:
 *                -   VR   - name of the data entry
 *                -   INST - instance index being tagged
 *                -   ATTR - name of the attribute (must be defined)
 *                -   AVL  - pointer to the attribute value data
 */

int PA_th_wr_iattr(strm, vr, inst, attr, avl)
   PDBfile *strm;
   char *vr;
   int inst;
   char *attr;
   byte *avl;
   {char t[MAXLINE];

    sprintf(t, "%s(%d)", vr, inst);
    return(PD_set_attribute(strm, t, attr, avl));}

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

/* PA_TH_TRANSPOSE - process a family of time history files into ULTRA files
 *
 *                 - NAME: base name of both the TH and ULTRA file families
 *                 - NCPF: maximum number of curves per ULTRA file
 */

/* THIS FUNCTION IS DEPRECATED - USE PA_TH_TRANS_FAMILY INSTEAD */

int PA_th_transpose(name, ncpf)
   char *name;
   int ncpf;
   {int i, nthf, ret;
    char **thfiles;

    nthf = PA_th_family_list(name, 't', &thfiles);

    ret  = PA_th_trans_files(name, ncpf, nthf, thfiles, 1, FALSE);

    for (i = 0; i < nthf; i++)
        SFREE(thfiles[i]);
    SFREE(thfiles);

    return(ret);}

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

/* PA_TH_TRANS_FAMILY - Process family of time history files into ULTRA files.
 *
 *                    - NAME: base name of both the TH and ULTRA file families
 *                    - ORD:  1 for normal order and -1 for reverse order
 *                    - NCPF: maximum number of curves per ULTRA file
 */

int PA_th_trans_family(name, ord, ncpf)
   char *name;
   int ord, ncpf;
   {int i, nthf, ret;
    char **thfiles;

    nthf = PA_th_family_list(name, 't', &thfiles);

    ret  = PA_th_trans_files(name, ncpf, nthf, thfiles, ord, FALSE);

    for (i = 0; i < nthf; i++)
        SFREE(thfiles[i]);
    SFREE(thfiles);

    return(ret);}

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

/* PA_TH_FAMILY_LIST - Create a list of all files in a family.
 *                   - Return the number of linked files.
 *
 *                   - NAME:   family name
 *                   - C:      't' for time history or 'u' for ultra files
 *                   - PFILES: pointer to list of files
 */

int PA_th_family_list(name, c, pfiles)
   char *name;
   int c;
   char ***pfiles;
   {int n, n_max;
    char **files, bf[MAXLINE];

    files  = NULL;
    n     = 0;
    n_max = 0;

    while (TRUE)
       {sprintf(bf, "%s.%c%s", name, c, SC_itoa(n, 36, 2));
        if (!SC_isfile(bf))
           {sprintf(PA_err, "ERROR: Cannot open file %s", bf);
            break;}
        SC_REMEMBER(char *, SC_strsavef(bf, "char*:PA_TH_FAMILY_LIST:bf"),
                                                    files, n, n_max, 50);};

    *pfiles = files;

    return(n);}

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

/* PA_TH_TRANS_NAME - transpose the explicitly named TH files
 *                  - N is the number of file names
 *                  - NAMES is the array of file names
 *                  - ORD is 1 for normal order and -1 for reverse order
 *                  - NCPF is the number of curves per ULTRA file
 *                  - returns TRUE iff successful
 */

int PA_th_trans_name(n, names, ord, ncpf)
   int n;
   char **names;
   int ord, ncpf;
   {int i, nthf, ret;
    char **thfiles, *root, bf[MAXLINE], *s;

    nthf = PA_th_name_list(n, names, &thfiles);

    strcpy(bf, names[0]);
    root = SC_strtok(bf, ".", s);
    ret  = PA_th_trans_files(root, ncpf, nthf, thfiles, ord, FALSE);

    for (i = 0; i < nthf; i++)
        SFREE(thfiles[i]);
    SFREE(thfiles);

    return(ret);}

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

/* PA_TH_NAME_LIST - Create a list of all existing files from a list of names.
 *                 - Return the number of files.
 *
 *                 - N:        number of names in original list
 *                 - NAMES:    original list of names
 *                 - PTHFILES: pointer to new list of existing files
 */

int PA_th_name_list(n, names, pthfiles)
   int n;
   char **names, ***pthfiles;
   {int i, nthf, nthf_max;
    PDBfile *fp;
    char **thfiles;

    thfiles  = NULL;
    nthf     = 0;
    nthf_max = 0;

    for (i = 0; i < n; i++)
        {fp = PD_open(names[i], "r");
         if (fp == NULL)
            {sprintf(PA_err, "ERROR: Cannot open file %s",
                     names[i]);
             break;}
         SC_REMEMBER(char *, SC_strsavef(names[i],
                     "char*:PA_TH_NAME_LIST:name"),
		     thfiles, nthf, nthf_max, 50);
         PD_close(fp);};

    *pthfiles = thfiles;

    return(nthf);}

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

/* PA_TH_TRANS_LINK - transpose the named TH files by following their links
 *                  - N is the number of file/link names
 *                  - NAMES is the array of file/link names
 *                  - ORD is 1 for normal order and -1 for reverse order
 *                  - NCPF is the number of curves per ULTRA file
 *                  - returns TRUE iff successful
 */


int PA_th_trans_link(n, names, ord, ncpf)
   int n;
   char **names;
   int ord, ncpf;
   {int i, nthf, ret;
    char *root, **thfiles, bf[MAXLINE], *s;

    nthf = PA_th_link_list(n, names, &thfiles);

    strcpy(bf, names[0]);
    root = SC_strtok(bf, ".", s);
    ret  = PA_th_trans_files(root, ncpf, nthf, thfiles, ord, FALSE);

    for (i = 0; i < nthf; i++)
        SFREE(thfiles[i]);
    SFREE(thfiles);

    return(ret);}

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

/* PA_TH_LINK_LIST - Create a list of all files linked to a given list.
 *                 - Return the number of linked files.
 *
 *                 - N:        number of file names in original list
 *                 - NAMES:    original list of file names
 *                 - PTHFILES: pointer to new list of files
 */

int PA_th_link_list(n, names, pthfiles)
   int n;
   char **names;
   char ***pthfiles;
   {int i, nthf, nthf_max;
    PDBfile *fp;
    char **thfiles, bf[MAXLINE];

    thfiles   = NULL;
    nthf      = 0;
    nthf_max  = 0;

    for (i = 0; i < n; i++)
        {strcpy(bf, names[i]);
	 while (TRUE)
            {fp = PD_open(bf, "r");
             if (fp == NULL)
                {sprintf(PA_err, "ERROR: Cannot open file %s", bf);
                 break;}
             SC_REMEMBER(char *, SC_strsavef(bf, "char*:PA_TH_LINK_LIST:bf"),
                                     thfiles, nthf, nthf_max, 50);
             if (fp->previous_file != NULL)
                {strcpy(bf, fp->previous_file);
                 PD_close(fp);}
             else
                {PD_close(fp);
                 break;};};};

    strcpy(bf, names[0]);
    *pthfiles = thfiles;

    return(nthf);}

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

/* PA_TH_TRANS_FILES - process a list of time history files into ULTRA files
 *                   - NAME is the base name of both the TH and ULTRA file
 *                   - families
 *                   - NCPF is the maximum number of curves per ULTRA file
 *                   - FLAG TRUE is verbose
 */

int PA_th_trans_files(name, ncpf, nthf, thfiles, ord, flag)
   char *name;
   int ncpf, nthf;
   char **thfiles;
   int ord, flag;
   {int i, j, n, ret;
    int n_min, n_inc;
    REAL *data, ext[2];
    char bf[MAXLINE], type[MAXLINE];
    PDBfile *th;

/* set up the family of ULTRA files */
    if (!_PA_setup_uf_family(name, thfiles, nthf, ncpf, flag))
       return(FALSE);

/* process the raw data files */
    if (ord == 1)
       {n_min = 0;
        n_inc = ord;}
    else
       {n_min = nthf - 1;
        n_inc = ord;};

    for (j = n_min; (j >= 0) && (j < nthf); j += n_inc)
        {th = PD_open(thfiles[j], "r");
         if (th == NULL)
            return(FALSE);

         for (i = 0; i < n_domains; i++)
             _PA_proc_rec(name, th, ncpf, i);

         if (!PD_close(th))
            {sprintf(PD_err,
                     "ERROR: TROUBLE CLOSING %s.t%02d - PA_TH_TRANS_FILES",
                     name, j);
             return(FALSE);};};

/* find the extrema */
    if (sizeof(REAL) == sizeof(double))
       strcpy(type, "double");
    else
       strcpy(type, "float");

    for (i = 0; i < n_domains; i++)
	{PD_read(uf[i], "npts0", &n);
	 data = FMAKE_N(REAL, n, "PA_TH_TRANS_FILES:data");
	 PD_read(uf[i], "xval0", data);
	 PM_maxmin(data, ext, ext + 1, n);
	 PD_write(uf[i], "xext0", type, ext);

	 for (j = 0; j < n_crv[i]; j++)
	     {sprintf(bf, "yval%d", j);
	      PD_read(uf[i], bf, data);
	      PM_maxmin(data, ext, ext + 1, n);
	      sprintf(bf, "yext%d", j);
	      PD_write(uf[i], bf, type, ext);};

         SFREE(data)};

/* clean up the memory */
    _PA_rl_th(th_data, n_domains);

    SFREE(th_data);
    SFREE(n_dpt);
    SFREE(n_crv);

/* close out the ULTRA files */
    ret = TRUE;
    for (i = 0; i < n_domains; i++)
        {if (PD_close(uf[i]))
            {if (flag)
                PRINT(stdout, "Closing ULTRA file %s.u%02d\n", name, i);}
         else
            {if (flag)
                PRINT(stdout, "Error closing ULTRA file %s.u%02d\n", name, i);
             ret = FALSE;};};

    SFREE(uf);

    return(ret);}

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

/* PA_MERGE_FAMILY - Merge the curves from ULTRA files with a given base name
 *                 - into one family of files.
 *
 *                 - BASE:   base name of the merged (target) files.
 *                 - FAMILY: is the base name of the family of files to merge. 
 *                 - NCPF:   approximate number of curves per target file.
 *                 -         (If NCPF = 0, don't family merged file.)
 */

int PA_merge_family(base, family, ncpf)
   char *base, *family;
   int ncpf;
   {int i, n, ret;
    char **files;

    n   = PA_th_family_list(family, 'u', &files);

    ret = PA_merge_files(base, n, files, ncpf);

    for (i = 0; i < n; i++)
        SFREE(files[i]);
    SFREE(files);

    return(ret);}

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

/* PA_MERGE_FILES - Merge the curves from an arbitrary list of ULTRA files
 *                - into a single family of files.
 *
 *                - BASE:  base name of the merged (target) files.
 *                - N:     number of file names in FILES.
 *                - FILES: list of source files to be merged.
 *                - NCPF:  approximate number of curves per target file.
 *                -        (If NCPF = 0, don't family merged file.)
 *
 *                - NOTE: This algorithm assumes that all curves in a given
 *                - source file share the domain in the first curve. This is
 *                - true for PANACEA time history files, but not in general.
 *                - Also, source files are not split across target files. Both
 *                - of these features are subject to change with some loss of
 *                - efficiency and simplicity.
 */

int PA_merge_files(base, n, files, ncpf)
   char *base;
   int n;
   char **files;
   int ncpf;
   {int i, ics, ix, ict, nc, npts, err;
    PDBfile *fpt, *fps;
    char s[MAXLINE], **names;
    REAL xmin, xmax, ymin, ymax, *px, *py;
    
    if (n <= 0)
       {sprintf(PD_err, "ERROR: NO FILES SPECIFIED - PA_MERGE_FILES");
	return(FALSE);};

    ict = 0;
    sprintf(s, "%s.u00", base);
    fpt = PD_open(s, "w");
    if (fpt == NULL)
       return(FALSE);

/*  Force PD_family to create a new file each time it is called below */
    PD_set_max_file_size(fpt, 0L);

    for (i = 0; i < n; i++)
        {fps = PD_open(files[i], "r");
	 if (fps == NULL)
	    {PRINT(stdout, "WARNING: CANNOT OPEN FILE %s - PA_MERGE_FILES\n",
		   files[i]);
	     continue;};
	 nc    = fps->symtab->nelements;
	 names = SC_hash_dump(fps->symtab, "*curve*");
	 if (names == NULL)
	    {PRINT(stdout, "WARNING: NO CURVES IN FILE %s - PA_MERGE_FILES\n",
		   files[i]);
	     PD_close(fps);
	     continue;};

	 for (ics = 0, ix = ict; (names[ics] != NULL) && (ics < nc); ics++)
	     {err = TRUE;
	      if (ics == 0)
		 {if (PD_read_pdb_curve(fps, names[ics], &px, &py, &npts, s,
					  &xmin, &xmax, &ymin, &ymax, X_AND_Y))
		     err = !PD_wrt_pdb_curve(fpt, s, npts, px, py, ict++);
		  if (err)
		     {PRINT(stdout,
			    "WARNING: SKIPPED BAD FILE %s - PA_MERGE_FILES\n",
			    files[i]);
		      ict--;
		      break;};}
	      else
		 {if (PD_read_pdb_curve(fps, names[ics], &px, &py, &npts, s,
					&xmin, &xmax, &ymin, &ymax, Y_ONLY))
		     err = !PD_wrt_pdb_curve_y(fpt, s, npts, ix, py, ict++);
		  if (err)
		     {PRINT(stdout,
			    "WARNING: SKIPPED CURVE %d FILE %s - PA_MERGE_FILES\n",
			    ics + 1, files[i]);
		      ict--;};};};
	 SFREE(names);

	 if ((ncpf != 0) && (ict >= ncpf) && ((i + 1) < n))
	    {fpt = PD_family(fpt, TRUE);
	     ict = 0;};
	 PD_close(fps);};

    PD_close(fpt);

    return(TRUE);}

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

/* _PA_SETUP_UF_FAMILY - analyze the given TH file which should be the last
 *                     - one of its family and determine the composition of
 *                     - the corresponding ULTRA file family
 */

static int _PA_setup_uf_family(name, thfiles, nthf, ncpf, flag)
   char *name, **thfiles;
   int nthf, ncpf, flag;
   {int i, j, k, n_max, nc, np;
    long ind[3];
    char bf[MAXLINE], tag[MAXLINE], type[MAXLINE], *pl;
    REAL ext[2];
    syment *ep;
    dimdes *dp;
    PDBfile *puf, *th;

    if (nthf <= 0)
       return(FALSE);

    if (sizeof(REAL) == sizeof(double))
       strcpy(type, "double");
    else
       strcpy(type, "float");

    n_max   = 10;
    th_data = FMAKE_N(th_record, n_max, "_PA_SETUP_UF_FAMILY:th_data");
    n_dpt   = FMAKE_N(dimdes, n_max, "_PA_SETUP_UF_FAMILY:n_dpt");
    n_crv   = FMAKE_N(int, n_max, "_PA_SETUP_UF_FAMILY:n_crv");
    for (k = 0; k < n_max; k++)
        {th_data[k].n_members = 0;
	 n_dpt[k].index_min = LONG_MAX;
         n_dpt[k].index_max = 0L;};

/* get the defining data from the TH files
 *   # of curves = sum of number of labels for each TH type
 *   # of point per domain = max value of dimension index for each TH type
 *   array of TH types
 */
    n_domains = 0;
    for (j = 0; j < nthf; j++)
        {th = PD_open(thfiles[j], "r");
         if (th == NULL)
            return(FALSE);

         for (i = 0; TRUE; i++)
             {sprintf(bf, "th%d", i);
              ep = PD_inquire_entry(th, bf, FALSE, NULL);
              if (ep == NULL)
                 break;

	      _PA_rl_th(&th_data[i], 1);

              if (!PD_read(th, bf, &th_data[i]))
                 break;

              ep = PD_inquire_entry(th, th_data[i].entry_name, FALSE, NULL);
              dp = PD_entry_dimensions(ep);

              n_dpt[i].index_min = min(n_dpt[i].index_min, dp->index_min);
              n_dpt[i].index_max = max(n_dpt[i].index_max, dp->index_max);

              n_crv[i] = SC_arrlen(th_data[i].labels)/sizeof(char *);

              if (i >= (n_max - 1))
                 {n_max += 10;
                  th_data = REMAKE_N(th_data, th_record, n_max);
                  n_dpt   = REMAKE_N(n_dpt, dimdes, n_max);
                  for (k = n_max - 10; k < n_max; k++)
                      {th_data[k].n_members = 0;
		       n_dpt[k].index_min = LONG_MAX;
                       n_dpt[k].index_max = 0L;};
                  n_crv = REMAKE_N(n_crv, int, n_max);};};

         n_domains = max(n_domains, i);

         PD_close(th);};

    for (i = 0; i < n_domains; i++)
        n_dpt[i].number = n_dpt[i].index_max - n_dpt[i].index_min + 1L;

    uf = FMAKE_N(PDBfile *, n_domains, "_PA_SETUP_UF_FAMILY:uf");
    ind[0] = 0L;
    ind[2] = 1L;
    for (i = 0; i < n_domains; i++)
        {sprintf(bf, "%s.u%02d", name, i);
         puf = PD_open(bf, "w");
         if (puf == NULL)
            return(FALSE);

         if (flag || _PA_ul_print_flag)
            PRINT(stdout, "Creating ULTRA file %s\n", bf);

         uf[i] = puf;

/* NOTE: put in something here to map the attributes over */

         nc = n_crv[i];
         np = n_dpt[i].number;

/* write the curve n_points */
         PD_write(puf, "npts0", "integer", &np);

/* intialize extrema to dummy values */
	 ext[0] =  HUGE;
	 ext[1] = -HUGE;

/* write dummy x extrema */
         PD_write(puf, "xext0(2)", type, ext);

/* reserve the x values space */
         ind[1] = np - 1;
         PD_defent_alt(puf, "xval0", type, 1, ind);

/* write the tags, labels, and n_points for each file */
         for (j = 0; j < nc; j++)
             {sprintf(tag,
                      "|labl%d|npts0|xval0|yval%d|xext0|yext%d|",
                      j, j, j);

/* write the curve tag */
              sprintf(bf, "curve%04d", j);
              ind[1] = strlen(tag);
              PD_write_alt(puf, bf, "char", tag, 1, ind);

/* write the curve label */
              pl = th_data[i].labels[j];
              sprintf(bf, "labl%d", j);
              ind[1] = strlen(pl);
              PD_write_alt(puf, bf, "char", pl, 1, ind);

/* write dummy y extrema */
	      sprintf(bf, "yext%d(2)", j);
	      PD_write(puf, bf, type, ext);

/* reserve the y values space */
              sprintf(bf, "yval%d", j);
              ind[1] = np - 1;
              PD_defent_alt(puf, bf, type, 1, ind);};};

    return(TRUE);}

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

/* _PA_TYPE_MIX - report the member type mix in the given type
 *              - if the members all have one type, return its value
 *              - else return HETEROGENEOUS
 */

static char *_PA_type_mix(file, type)
   PDBfile *file;
   char *type;
   {defstr *dp;
    memdes *desc;
    static char t[MAXLINE];

    dp = PD_inquire_type(file, type);
    if (dp == NULL)
       return(NULL);

    desc = dp->members;
    if (desc == NULL)
       return(type);

    strcpy(t, desc->type);
    for (; desc != NULL; desc = desc->next)
        {if (strcmp(t, desc->type) != 0)
            return(HETEROGENEOUS);};

    return(t);}

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

/* _PA_TRANSPOSE_STRIPE - copy and convert the stripe data which may 
 *                      - be of mixed type (heterogeneous struct) into
 *                      - the curve arrays which are of type double
 */

static int _PA_transpose_stripe(file, crve, stripe, type, mix, na, nrd)
   PDBfile *file;
   REAL **crve;
   char *stripe;
   char *type, *mix;
   int na, nrd;
   {int j, k, nv, ns;
    defstr *dp;
    memdes *desc;
    REAL *data, *pd;

    dp = PD_inquire_type(file, type);

    desc = dp->members;
    if (desc == NULL)
       nv = 1;
    else
       for (nv = 0; desc != NULL; desc = desc->next, nv++);

    if (strcmp(mix, HETEROGENEOUS) == 0)
       {int tmp, incr;
        long mitems, offs, bpm;
        char *ps, *mtype;
        HASHTAB *tab;

        tab  = file->host_chart;
        offs = 0L;
        ps   = stripe;
        for (k = na; k < nrd; k++)
            {incr  = _PD_align(offs, type, tab, &tmp);
             offs += incr;
             ps   += incr;
             for (j = 0, desc = dp->members;
                  desc != NULL;
                  j++, desc = desc->next)
                 {mitems = desc->number;
                  mtype  = desc->type;
                  bpm    = mitems*_PD_lookup_size(mtype, tab);
                  incr   = _PD_align(offs, mtype, tab, &tmp);

/* increment the offsets to the alignments */
                  offs += incr;
                  ps   += incr;

                  pd = &crve[j][k];
                  CONVERT(SC_DOUBLE_S, &pd, mtype, ps, 1, FALSE);

/* increment to the next member */
                  offs += bpm;
                  ps   += bpm;};};}

    else
       {data = NULL;
        ns   = (nrd - na)*nv;
        CONVERT(SC_REAL_S, &data, mix, stripe, ns, FALSE);

        pd = data;
        for (k = na; k < nrd; k++)
            {for (j = 0; j < nv; j++)
                 crve[j][k] = *pd++;};

        SFREE(data);};

    return(ns*nv);}

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

/* _PA_PROC_REC - process a single time history data set from a single file */

static int _PA_proc_rec(name, th, ncpf, recn)
   char *name;
   PDBfile *th;
   int ncpf, recn;
   {int i, j, n, nc, nv, nptm;
    long ns, na, nrd, addr, nitems, offs, ind[3];
    char bf[MAXLINE], rname[MAXLINE], type[MAXLINE], *rtyp, *tmix;
    REAL **crve;
    syment *ep, *en;
    dimdes *dp;
    symblock *sp;
    PDBfile *pduf;
    FILE *fp;
    byte *stripe;

    strcpy(rname, th_data[recn].entry_name);
    ep = PD_inquire_entry(th, rname, FALSE, NULL);
    if (ep == NULL)
       return(FALSE);

    dp   = PD_entry_dimensions(ep);
    rtyp = PD_entry_type(ep);

    tmix = _PA_type_mix(th, rtyp);
    if (tmix == NULL)
       return(FALSE);

    nc = n_crv[recn];
    nv = nc + 1;

    pduf = uf[recn];

/* read the data in from the pp file */
    sp = PD_entry_blocks(ep);
    n  = PD_n_blocks(ep);
    if (n == 1)
       sp[0].number = PD_entry_number(ep);

    en = _PD_mk_syment(NULL, 0L, 0L, NULL, NULL);

    PD_entry_type(en) = rtyp;
    SC_mark(rtyp, 1);

/* find the maximum number of stripes laid out */
    ns = 0L;
    for (i = 0; i < n; i++)
        {nitems = sp[i].number;
         ns = max(ns, nitems);};

    stripe = _PD_alloc_entry(th, rtyp, ns);

/* allocate the curve arrays */
    crve = FMAKE_N(REAL *, nv, "_PA_PROC_REC:crve");
    if (sizeof(REAL) == sizeof(double))
       strcpy(type, "double");
    else
       strcpy(type, "float");

    nptm = n_dpt[recn].number;
    for (i = 0; i < nv; i++)
        crve[i] = FMAKE_N(REAL, nptm, "_PA_PROC_REC:crve[]");

    fp  = th->stream;
    na  = 0L;
    nrd = 0L;
    for (i = 0; i < n; i++)
        {addr   = sp[i].diskaddr;
         nitems = sp[i].number;
         if (io_seek(fp, addr, SEEK_SET))
            {sprintf(PD_err, "ERROR: SEEK FAILED - _PA_PROC_REC");
             return(FALSE);};

         PD_entry_address(en) = addr;
         PD_entry_number(en)  = nitems;

         nrd += _PD_rd_syment(th, en, rtyp, stripe);

/* transpose through the copy */
         _PA_transpose_stripe(th, crve, stripe, rtyp, tmix, na, nrd);

         na = nrd;};

    _PD_rl_syment(en);

/* setup the index for all curve data */
/*
    offs = th->default_offset;
    ind[0] = 0L;
    ind[1] = dp->index_max - dp->index_min;
*/
    offs = n_dpt[recn].index_min;

    ind[0] = dp->index_min - offs;
    ind[1] = dp->index_max - offs;
    ind[2] = 1L;

/* write out the time plot domain data */
    PD_write_alt(pduf, "xval0", type, crve[0], 1, ind);

    SFREE(crve[0]);

/* write out the time plot range data */
    for (i = 0; i < nc; i++)
        {j = i + 1;
         sprintf(bf, "yval%d", i);
         PD_write_alt(pduf, bf, type, crve[j], 1, ind);
         SFREE(crve[j]);};

    SFREE(stripe);
    SFREE(crve);

    return(TRUE);}

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

/*                        FORTRAN API ROUTINES                              */

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

/* PATHOP - open a time history file */

FIXNUM F77_ID(pathop_, pathop, PATHOP)(pnf, fname, pnm, fmode, psz,
                                       pnp, fprev)
   FIXNUM *pnf;
   F77_string fname;
   FIXNUM *pnm;
   F77_string fmode;
   FIXNUM *psz, *pnp;
   F77_string fprev;
   {PDBfile *file;
    char s[MAXLINE], t[2], u[MAXLINE], *lmode;
    int np;

    SC_FORTRAN_STR_C(s, fname, *pnf);

    lmode = SC_F77_C_STRING(fmode);

    t[0] = *lmode;
    t[1] = '\0';

    np = *pnp;
    if (np == 0)
       file = PA_th_open(s, t, (long) *psz, NULL);
    else
       {SC_FORTRAN_STR_C(u, fprev, np);
        file = PA_th_open(s, t, (long) *psz, u);};

    if (file == NULL)
       return((FIXNUM) -1);
    else
       {file->major_order    = COLUMN_MAJOR_ORDER;
        file->default_offset = 1;

        return((FIXNUM) SC_ADD_POINTER(file));};}

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

/* PATHFM - check the file and return the next member of the family 
 *        - if appropriate
 */

FIXNUM F77_ID(pathfm_, pathfm, PATHFM)(fileid)
   FIXNUM *fileid;
   {PDBfile *file, *newfile;
    FIXNUM ret;

    file = SC_GET_POINTER(PDBfile, *fileid);
    ret = *fileid;    

    newfile = PA_th_family(file);

    if (newfile != file)
       {ret = SC_ADD_POINTER(newfile);
        file = SC_DEL_POINTER(PDBfile, *fileid);}
        
    if (newfile == NULL)
       return((FIXNUM) -1);
    else
       {newfile->major_order    = COLUMN_MAJOR_ORDER;
        newfile->default_offset = 1;

        return(ret);};}

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

/* PABREC - begin a time domain struct definition */

FIXNUM F77_ID(pabrec_, pabrec, PABREC)(fileid, pnf, fname, pnt, ftype,
                                       pnd, ftime)
   FIXNUM *fileid, *pnf;
   F77_string fname;
   FIXNUM *pnt;
   F77_string ftype;
   FIXNUM *pnd;
   F77_string ftime;
   {f77_th_record *fth;
    size_t nc;
    char ltype[MAXLINE], lname[MAXLINE], ltime[MAXLINE];

    nc = *pnt;
    SC_FORTRAN_STR_C(ltype, ftype, nc);

    nc = *pnf;
    SC_FORTRAN_STR_C(lname, fname, nc);

    fth = FMAKE(f77_th_record, "PABREC:fth");
    
    fth->labels        = FMAKE_N(char *, 10, "PABREC:labels");
    fth->n_labels      = 0;
    fth->n_labels_max  = 10;
    fth->members       = FMAKE_N(char *, 10, "PABREC:members");
    fth->n_members     = 0;
    fth->n_members_max = 10;
    fth->type          = SC_strsavef(ltype, "char*:PABREC:type");
    fth->entry_name    = SC_strsavef(lname, "char*:PABREC:name");

    nc = *pnd;
    SC_FORTRAN_STR_C(ltime, ftime, nc);

    SC_REMEMBER(char *, SC_strsavef(ltime, "char*:PABREC:ltime"),
          fth->members, fth->n_members, fth->n_members_max, 10);

    return((FIXNUM) SC_ADD_POINTER(fth));}

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

/* PAGRID - return the record id for the named record */

FIXNUM F77_ID(pagrid_, pagrid, PAGRID)(fileid, pind, pnn, name,
				       pnt, type, prid)
   FIXNUM *fileid, *pind, *pnn;
   F77_string name;
   FIXNUM *pnt;
   F77_string type;
   FIXNUM *prid;
   {PDBfile *file;
    char dname[MAXLINE], *s;
    int n;
    f77_th_record *fth;
    th_record th_data;

    file = SC_GET_POINTER(PDBfile, *fileid);
    
    sprintf(dname, "th%d", (int) *pind);
    if (!PD_read(file, dname, &th_data))
       return((FIXNUM) FALSE);

    fth = FMAKE(f77_th_record, "PAGRID:fth");
    
    fth->labels        = th_data.labels;
    fth->n_labels      = th_data.n_members - 1;
    fth->n_labels_max  = fth->n_labels;
    fth->members       = th_data.members;
    fth->n_members     = th_data.n_members;
    fth->n_members_max = th_data.n_members;
    fth->type          = th_data.type;
    fth->entry_name    = th_data.entry_name;

    s = th_data.entry_name;
    n = strlen(s);
    n = min(n, *pnn);
    strncpy(SC_F77_C_STRING(name), s, n);
    *pnn = n;

    s = th_data.type;
    n = strlen(s);
    n = min(n, *pnt);
    strncpy(SC_F77_C_STRING(type), s, n);

    *pnt  = n;
    *prid = (FIXNUM) SC_ADD_POINTER(fth);

    return((FIXNUM) TRUE);}

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

/* PAAREC - add a member to a time domain struct definition */

FIXNUM F77_ID(paarec_, paarec, PAAREC)(fileid, recid, pnm, fmemb,
                                       pnl, flabl)
   FIXNUM *fileid, *recid;
   FIXNUM *pnm;
   F77_string fmemb;
   FIXNUM *pnl;
   F77_string flabl;
   {f77_th_record *fth;
    int nc;
    char lmemb[MAXLINE], llabl[MAXLINE], *s;

    fth  = SC_GET_POINTER(f77_th_record, *recid);

    nc = *pnm;
    SC_FORTRAN_STR_C(lmemb, fmemb, nc);

    nc = *pnl;
    SC_FORTRAN_STR_C(llabl, flabl, nc);

    SC_REMEMBER(char *, SC_strsavef(lmemb, "char*:PAAREC:lmemb"),
                fth->members, fth->n_members, fth->n_members_max, 10);

    if (nc > 0)
       s = SC_strsavef(llabl, "char*:PAAREC:s");
    else
       s = NULL;

    SC_REMEMBER(char *, s, fth->labels,
                fth->n_labels, fth->n_labels_max, 10);

    return((FIXNUM) TRUE);}

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

/* PAEREC - finish a time domain struct definition */

FIXNUM F77_ID(paerec_, paerec, PAEREC)(fileid, recid)
   FIXNUM *fileid, *recid;
   {PDBfile *file;
    f77_th_record *fth;
    defstr *dp;

    file = SC_GET_POINTER(PDBfile, *fileid);
    fth  = SC_GET_POINTER(f77_th_record, *recid);

    dp = PA_th_def_rec(file, fth->entry_name, fth->type,
                       fth->n_members, fth->members, fth->labels);

    return((FIXNUM) (dp != NULL));}

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

/* PAWREC - write a time domain record */

FIXNUM F77_ID(pawrec_, pawrec, PAWREC)(fileid, recid, pinst, pnr, vr)
   FIXNUM *fileid, *recid;
   FIXNUM *pinst, *pnr;
   byte *vr;
   {PDBfile *file;
    f77_th_record *fth;
    int ret;

    file = SC_GET_POINTER(PDBfile, *fileid);
    fth  = SC_GET_POINTER(f77_th_record, *recid);

    ret = PA_th_write(file, fth->entry_name, fth->type,
                      (int) *pinst, (int) *pnr, vr);

    return((FIXNUM) ret);}

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

/* PAWMEM - write a time domain record member */

FIXNUM F77_ID(pawmem_, pawmem, PAWMEM)(fileid, recid, pnc, mbr, pinst, pnr, vr)
   FIXNUM *fileid, *recid, *pnc;
   F77_string mbr;
   FIXNUM *pinst, *pnr;
   byte *vr;
   {PDBfile *file;
    f77_th_record *fth;
    char memb[MAXLINE];
    int ret;

    file = SC_GET_POINTER(PDBfile, *fileid);
    fth  = SC_GET_POINTER(f77_th_record, *recid);

    SC_FORTRAN_STR_C(memb, mbr, *pnc);

    ret = PA_th_wr_member(file, fth->entry_name, memb, fth->type,
			  (int) *pinst, vr);

    return((FIXNUM) ret);}

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

/* PAWRIA - write a time domain record instance attribute */

FIXNUM F77_ID(pawria_, pawria, PAWRIA)(fileid, pnv, fvar,
                                       pinst,  pna, fattr, avl)
   FIXNUM *fileid, *pnv;
   F77_string fvar;
   FIXNUM *pinst, *pna;
   F77_string fattr;
   byte *avl;
   {PDBfile *file;
    int ret;
    char lvar[MAXLINE], lattr[MAXLINE];

    file = SC_GET_POINTER(PDBfile, *fileid);

    SC_FORTRAN_STR_C(lvar, fvar, *pnv);
    SC_FORTRAN_STR_C(lattr, fattr, *pna);

    ret = PA_th_wr_iattr(file, lvar, (int) *pinst, lattr, avl);

    return((FIXNUM) ret);}

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

/* PATHTR - transpose a time history file family */
/* THIS FUNCTION IS DEPRECATED - USE PATRNF INSTEAD */

FIXNUM F77_ID(pathtr_, pathtr, PATHTR)(pnf, fname, pncpf)
   FIXNUM *pnf;
   F77_string fname;
   FIXNUM *pncpf;
   {int ret;
    char s[MAXLINE];

    SC_FORTRAN_STR_C(s, fname, *pnf);

    ret = PA_th_trans_family(s, 1, (int) *pncpf);

    return((FIXNUM) ret);}

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

/* PATRNF - transpose a time history file family
 *        - Return 1 if successful and 0 otherwise.
 */

FIXNUM F77_ID(patrnf_, patrnf, PATRNF)(pnf, fname, pord, pncpf)
   FIXNUM *pnf;
   F77_string fname;
   FIXNUM *pord, *pncpf;
   {int ret;
    char s[MAXLINE];

    SC_FORTRAN_STR_C(s, fname, *pnf);

    ret = PA_th_trans_family(s, (int) *pord, (int) *pncpf);

    return((FIXNUM) ret);}

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

/* PATHTN - transpose a time history file family by explicit names */
/* THIS FUNCTION IS DEPRECATED - USE PATRNN INSTEAD */

FIXNUM F77_ID(pathtn_, pathtn, PATHTN)(chrs, pord, pncpf)
   F77_string chrs;
   FIXNUM *pord, *pncpf;
   {int i, n, n_max, ret;
    char **names, *pc, *token, *s;

    pc    = SC_F77_C_STRING(chrs);
    names = NULL;
    n     = 0;
    n_max = 0;

    while (TRUE)
       {token = SC_strtok(pc, " \t\f\n\r", s);
        if (token == NULL)
           break;
        SC_REMEMBER(char *, SC_strsavef(token, "char*:PATHTN:token"),
                     names, n, n_max, 50);
        pc = NULL;};

    ret = PA_th_trans_name(n, names, (int) *pord, (int) *pncpf);

    for (i = 0; i < n; i++)
        SFREE(names[i]);
    SFREE(names);

    return((FIXNUM) ret);}

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

/* PATRNN - transpose a time history file family by explicit names
 *        - Return 1 if successful and 0 otherwise.
 */

FIXNUM F77_ID(patrnn_, patrnn, PATRNN)(pnchrs, chrs, pord, pncpf)
   FIXNUM *pnchrs;
   F77_string chrs;
   FIXNUM *pord, *pncpf;
   {int i, n, n_max, ret;
    char **names, *pc, *token;

    pc    = FMAKE_N(char, *pnchrs + 2, "PATRNN:pc");
    SC_FORTRAN_STR_C(pc, chrs, *pnchrs);
    names = NULL;
    n     = 0;
    n_max = 0;

    while (TRUE)
       {token = SC_firsttok(pc, " \t\f\n\r");
        if (token == NULL)
           break;
        SC_REMEMBER(char *, SC_strsavef(token, "char*:PATRNN:token"),
                      names, n, n_max, 50);};

    ret = PA_th_trans_name(n, names, (int) *pord, (int) *pncpf);

    for (i = 0; i < n; i++)
        SFREE(names[i]);
    SFREE(names);
    SFREE(pc);

    return((FIXNUM) ret);}

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

/* PATHTL - transpose a time history file family by links */
/* THIS FUNCTION IS DEPRECATED - USE PATRNL INSTEAD */

FIXNUM F77_ID(pathtl_, pathtl, PATHTL)(chrs, pord, pncpf)
   F77_string chrs;
   FIXNUM *pord, *pncpf;
   {int i, n, n_max, ret;
    char **names, *pc, *token, *s;

    pc    = SC_F77_C_STRING(chrs);
    names = NULL;
    n     = 0;
    n_max = 0;

    while (TRUE)
       {token = SC_strtok(pc, " \t\f\n\r", s);
        if (token == NULL)
           break;
        SC_REMEMBER(char *, SC_strsavef(token, "char*:PATHTL:token"),
                        names, n, n_max, 50);
        pc = NULL;};

    ret = PA_th_trans_link(n, names, (int) *pord, (int) *pncpf);
    
    for (i = 0; i < n; i++)
        SFREE(names[i]);
    SFREE(names);

    return((FIXNUM) ret);}

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

/* PATRNL - transpose a time history file family by links
 *        - Return 1 if successful and 0 otherwise.
 */

FIXNUM F77_ID(patrnl_, patrnl, PATRNL)(pnchrs, chrs, pord, pncpf)
   FIXNUM *pnchrs;
   F77_string chrs;
   FIXNUM *pord, *pncpf;
   {int i, n, n_max, ret;
    char **names, *pc, *token;

    pc    = FMAKE_N(char, *pnchrs + 2, "PATRNL:pc");
    SC_FORTRAN_STR_C(pc, chrs, *pnchrs);
    names = NULL;
    n     = 0;
    n_max = 0;

    while (TRUE)
       {token = SC_firsttok(pc, " \t\f\n\r");
        if (token == NULL)
           break;
        SC_REMEMBER(char *, SC_strsavef(token, "char*:PATRNL:token"),
                       names, n, n_max, 50);};

    ret = PA_th_trans_link(n, names, (int) *pord, (int) *pncpf);
    
    for (i = 0; i < n; i++)
        SFREE(names[i]);
    SFREE(names);
    SFREE(pc);

    return((FIXNUM) ret);}

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

/* PAMRGF - FORTRAN interface routine to merge a family of ULTRA files
 *        - Return 1 if successful and 0 otherwise.
 *
 *        - PNB:    Number of characters in BASE.
 *        - BASE:   Base name of target (merged) file family.
 *        - PNF:    Number of characters in FAMILY.
 *        - FAMILY: Base name of source file family.
 *        - PNCPF:  Number of curves per target file.
 */

FIXNUM F77_ID(pamrgf_, pamrgf, PAMRGF)(pnb, base, pnf, family, pncpf)
   FIXNUM *pnb;
   F77_string base;
   FIXNUM *pnf;
   F77_string family;
   FIXNUM *pncpf;
   {int ret;
    char s[MAXLINE];
    char t[MAXLINE];

    SC_FORTRAN_STR_C(s, base, *pnb);
    SC_FORTRAN_STR_C(t, family, *pnf);

    ret = PA_merge_family(s, t, (int) *pncpf);

    return((FIXNUM) ret);}

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

/* PAMRGN - FORTRAN interface routine to merge a list of ULTRA files.
 *        - Return 1 if successful and 0 otherwise.
 *
 *        - PNB:    Number of characters in BASE.
 *        - BASE:   Base name of target (merged) file family.
 *        - PNCHRS: Number of characters in CHRS.
 *        - CHRS:   List of file names.
 *        - PNCPF:  Number of curves per target file.
 */

FIXNUM F77_ID(pamrgn_, pamrgn, PAMRGN)(pnb, base, pnchrs, chrs, pncpf)
   FIXNUM *pnb;
   F77_string base;
   FIXNUM *pnchrs;
   F77_string chrs;
   FIXNUM *pncpf;
   {int i, n, n_max, ret;
    char **files, *pc, *token, s[MAXLINE];

    pc    = FMAKE_N(char, *pnchrs + 2, "PAMRGN:pc");
    SC_FORTRAN_STR_C(pc, chrs, *pnchrs);
    SC_FORTRAN_STR_C(s, base, *pnb);
    files = NULL;
    n     = 0;
    n_max = 0;

    while (TRUE)
       {token = SC_firsttok(pc, " \t\f\n\r");
        if (token == NULL)
           break;
        SC_REMEMBER(char *, SC_strsavef(token, "char*:PAMRGN:token"),
                         files, n, n_max, 50);};

    ret = PA_merge_files(s, n, files, (int) *pncpf);

    for (i = 0; i < n; i++)
        SFREE(files[i]);
    SFREE(files);
    SFREE(pc);

    return((FIXNUM) ret);}

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

/* PAFREC - Free a time domain record */

FIXNUM F77_ID(pafrec_, pafrec, PAFREC)(recid)
   FIXNUM *recid;
   {f77_th_record *fth;
    int i, n;
    char **str;

    fth = SC_GET_POINTER(f77_th_record, *recid);

    str = fth->labels;
    n   = fth->n_labels;
    for (i = 0; i < n; i++)
        SFREE(str[i]);
    SFREE(str);

    str = fth->members;
    n   = fth->n_members;
    for (i = 0; i < n; i++)
        SFREE(str[i]);
    SFREE(str);

    SFREE(fth->type);
    SFREE(fth->entry_name);

    SFREE(fth);

    return((FIXNUM) TRUE);}

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

/* _PA_RL_TH - Free the members of a th_record */

static void _PA_rl_th(thd, nthd)
   th_record *thd;
   int nthd;
   {int i, j, n;
    char **str;

    for (i = 0; i < nthd; i++)
        {if (thd[i].n_members != 0)
	    {str = thd[i].members;
	     n   = SC_arrlen(str)/sizeof(char *);
	     for (j = 0; j < n; j++)
	         SFREE(str[j]);
	     SFREE(thd[i].members);

	     str = thd[i].labels;
	     n   = SC_arrlen(str)/sizeof(char *);
	     for (j = 0; j < n; j++)
	         SFREE(str[j]);
	     SFREE(thd[i].labels);

	     SFREE(thd[i].type);
	     SFREE(thd[i].entry_name);
	     
	     thd[i].n_members = 0;};};

    return;}

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