diff options
Diffstat (limited to 'Ganlib/src/xsm_c.c')
| -rw-r--r-- | Ganlib/src/xsm_c.c | 1235 |
1 files changed, 1235 insertions, 0 deletions
diff --git a/Ganlib/src/xsm_c.c b/Ganlib/src/xsm_c.c new file mode 100644 index 0000000..7abbf1f --- /dev/null +++ b/Ganlib/src/xsm_c.c @@ -0,0 +1,1235 @@ + +/**********************************/ +/* C API for xsm file support */ +/* author: A. Hebert (30/04/2002) */ +/**********************************/ + +/* + Copyright (C) 2002 Ecole Polytechnique de Montreal + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + */ + +#include <stdlib.h> +#include <string.h> +#include "xsm.h" + +#define iprim 3 +#define iwrd 3 +#define klong 5+iwrd+(3+iwrd)*iofmax +#if !defined(min) +#define min(A,B) ((A) < (B) ? (A) : (B)) +#endif +#define TRUE 1 /* valeur boolenne TRUE */ +#define FALSE 0 /* valeur boolenne FALSE */ + +static char AbortString[132]; + +/* Table of constant values */ + +static int_32 c__0 = 0; +static int_32 c__1 = 1; +static int_32 c__2 = 2; +static int_32 c__8 = 8; +static char *bl12=" "; + +void xsmkep(db1 *ipkeep, int_32 imode, xsm **iplist) +/* + *----------------------------------------------------------------------- + * + * keep the addresses of the open active directories. + * + * input parameters: + * ipkeep : address of the database handle (always the same). + * imode : =1: add to the database; =2: remove from the database. + * iplist : address of an active directory. + * + * output parameter: + * iplist : last active directory in the database. =0 if the + * database is empty. + * + * database handle structure: + * 0 : number of addresses in the database. + * 1 : maximum slots in the database. + * 2 : address of the database. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmkep"; + int_32 n = ipkeep->nad; + if (imode == 1) { + int_32 i; + xsm **my_parray; + if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: WRONG HEADER(1).",nomsub); + xabort_c(AbortString); + } else if (ipkeep->nad + 1 > ipkeep->maxad) { + ipkeep->maxad += maxit; + my_parray = (xsm **) malloc((ipkeep->maxad)*sizeof(*my_parray)); + for (i = 0; i < n; ++i) my_parray[i]=ipkeep->idir[i]; + if (n > 0) free(ipkeep->idir); + ipkeep->idir=my_parray; + } + ++ipkeep->nad; + ipkeep->idir[n] = *iplist; + } else if (imode == 2) { + int_32 i, i0=0; + for (i = n; i >= 1; --i) { + if (ipkeep->idir[i-1] == *iplist) { + i0 = i; + goto L30; + } + } + sprintf(AbortString,"%s: UNABLE TO FIND AN ADDRESS.",nomsub); + xabort_c(AbortString); +L30: + for (i = i0; i <= n-1; ++i) + ipkeep->idir[i-1]=ipkeep->idir[i]; + --ipkeep->nad; + if (ipkeep->nad == 0) { + *iplist = NULL; + free(ipkeep->idir); + ipkeep->maxad=0; + ipkeep->idir=NULL; + } else { + *iplist = ipkeep->idir[n-1]; + if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: WRONG HEADER(2).",nomsub); + xabort_c(AbortString); + } + } + } else { + sprintf(AbortString,"%s: INVALID VALUE OF IMODE.",nomsub); + xabort_c(AbortString); + } + return; +} + +void xsmdir(int_32 *ind, block2 *my_block2) +/* + *----------------------------------------------------------------------- + * + * import or export a directory using the kdi utility. + * + * input parameters: + * ind : =1 for import ; =2 for export. + * my_block2 : address of memory-resident xsm structure (block 2). + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmdir"; + int_32 i,j,irc,ibuf[9],ipos,iofma2,iivec[6*iofmax]; + ipos = my_block2->idir; + if (*ind == 1) { + irc = kdiget_c(my_block2->ifile, ibuf, ipos, c__8); + if (irc != 0) goto L40; + if (strncmp((char*)ibuf,"$$$$",4) != 0) goto L30; + iofma2 = ibuf[1]; + if (iofma2 > iofmax) goto L30; + my_block2->nmt = ibuf[2]; + my_block2->link = ibuf[3]; + my_block2->iroot = ibuf[4]; + strncpy(my_block2->mynam,(char*)&ibuf[5],12); + my_block2->mynam[12]='\0'; + for(i=11; i>0; i--) { + if(my_block2->mynam[i] != ' ') break; + my_block2->mynam[i]='\0'; + } + if (my_block2->nmt == 0) return; + ipos += c__8; + irc = kdiget_c(my_block2->ifile, iivec, ipos, 6*iofma2); + if (irc != 0) goto L40; + for(i=0; i<my_block2->nmt; i++) { + my_block2->iofs[i] = iivec[i]; + my_block2->jlon[i] = iivec[iofma2+i]; + my_block2->jtyp[i] = iivec[2*iofma2+i]; + strncpy(my_block2->cmt[i],(char*)&iivec[3*(iofma2+i)],12); + my_block2->cmt[i][12]='\0'; + for(j=11; j>0; j--) { + if(my_block2->cmt[i][j] != ' ') break; + my_block2->cmt[i][j]='\0'; + } + } + } else if (*ind == 2) { + my_block2->modif = 0; + const char *src = "$$$$"; + memcpy((char*)ibuf,src,strlen(src)); + ibuf[1] = iofmax; + ibuf[2] = my_block2->nmt; + ibuf[3] = my_block2->link; + ibuf[4] = my_block2->iroot; + memcpy((char*)&ibuf[5],bl12,12); + strncpy((char*)&ibuf[5],my_block2->mynam,min(12,strlen(my_block2->mynam))); + irc = kdiput_c(my_block2->ifile, ibuf, ipos, c__8); + if (irc != 0) goto L50; + ipos += c__8; + memset(iivec, 0, 6*iofmax*sizeof(iivec[0])); + for(i=0; i<my_block2->nmt; i++) { + iivec[i] = my_block2->iofs[i]; + iivec[iofmax+i] = my_block2->jlon[i]; + iivec[2*iofmax+i] = my_block2->jtyp[i]; + memcpy((char*)&iivec[3*(iofmax+i)],bl12,12); + strncpy((char*)&iivec[3*(iofmax+i)],my_block2->cmt[i],min(12,strlen(my_block2->cmt[i]))); + } + irc = kdiput_c(my_block2->ifile, iivec, ipos, 6*iofmax); + if (irc != 0) goto L50; + } + return; +/* ABORT ON FATAL ERRORS */ +L30: + sprintf(AbortString,"%s: UNABLE TO RECOVER DIRECTORY.",nomsub); + xabort_c(AbortString); +L40: + sprintf(AbortString,"%s: kdiget_c ERROR NB. %d.",nomsub,(int)irc); + xabort_c(AbortString); +L50: + sprintf(AbortString,"%s: kdiput_c ERROR NB. %d.",nomsub,(int)irc); + xabort_c(AbortString); +} + +void xsmop_c(xsm **iplist, char *namp, int_32 imp, int_32 impx) +/* + *----------------------------------------------------------------------- + * + * open an existing or create a new xsm file. + * + * The xsm database results from the juxtaposition of a hierarchical + * logical structure into a direct access file. The direct access file + * is ANSI-C or Fortran-77 compatible and is managed by kdiget/put/cl. + * xsmop/put/get/len/vec/nxt/cl entries provide a set of methods to + * access a xsm file. + * + * The logical structure of a xsm file is made of a root directory fol- + * lowed by variable-length blocks containing the useful information. + * Each time a directory is full, an extent is automatically created at + * the end of the file, so that the total number of blocks in a direc- + * tory is only limited by the maximum size of the direct access file. + * Any block can contain a sub-directory in order to create a hierar- + * chical structure. + * + * input parameters: + * namp : character name (null terminated) of the xsm file. + * imp : type of access. =0: new file mode; + * =1: modification mode; + * =2: read only mode. + * impx : if impx=0, we suppress printing on xsmop. + * + * output parameters: + * iplist : address of the handle to the xsm file. + * namp : character*12 name of the xsm file if imp=1 or imp=2. + * + * The active directory is made of two blocks linked together. A block 1 + * is allocated for each scalar directory or vector directory component. + * Block 2 is unique for a given xsm file; every block 1 is pointing to + * the same block 2. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmop_c"; + int_32 irc,ibuf; + char hbuf[5]; + block2 *my_block2; + db1 *my_db1; + db2 *my_db2; + kdi_file *my_file; + if (imp < 0 || imp > 2) { + sprintf(AbortString,"%s: INVALID ACTION ( %d ) ON XSM FILE '%s'.",nomsub,(int)imp,namp); + xabort_c(AbortString); + } else if (strlen(namp) > 72) { + sprintf(AbortString,"%s: FINENAME '%s' EXCEEDING 72 CHARACTERS.",nomsub,namp); + xabort_c(AbortString); + } + *iplist = (xsm *) malloc(sizeof(**iplist)); + my_block2 = (block2 *) malloc(sizeof(*my_block2)); + + my_db1 = (db1 *) malloc(sizeof(*my_db1)); + my_db1->nad = 0; + my_db1->maxad = 0; + my_db1->idir = NULL; + (*iplist)->icang = my_db1; + + my_db2 = (db2 *) malloc(sizeof(*my_db2)); + my_db2->nad = 0; + my_db2->maxad = 0; + my_db2->iref = NULL; + my_db2->iofset = NULL; + my_db2->lg = NULL; + (*iplist)->icang2 = my_db2; + + (*iplist)->header = 200; + (*iplist)->listlen = -1; + (*iplist)->impf = imp; + (*iplist)->ibloc = my_block2; + (*iplist)->father = NULL; + strcpy((*iplist)->hname,namp); + my_file = (kdi_file *) kdiop_c(namp,imp); + if (my_file == NULL) { + sprintf(AbortString,"%s: UNABLE TO OPEN XSM FILE '%s'.",nomsub,namp); + xabort_c(AbortString); + } + my_block2->ifile = my_file; + if (impx > 1) + printf("%s: KDI FILE OPEN = %ld NAME = '%s' ACTION = %d.\n",nomsub,(long)my_file->fd,namp,(int)imp); + if (imp >= 1) { +/* RECOVER THE ROOT DIRECTORY IF THE XSM FILE ALREADY EXISTS. */ + irc=kdiget_c(my_block2->ifile, &ibuf, c__0, c__1); + if (irc != 0) goto L140; + strncpy(hbuf,(char*)&ibuf,4); + hbuf[4]='\0'; + if (strcmp(hbuf,"$XSM") != 0) { + sprintf(AbortString,"%s: WRONG HEADER ON XSM FILE '%s'.",nomsub,namp); + xabort_c(AbortString); + } + irc=kdiget_c(my_block2->ifile, &(my_block2->ioft), c__1, c__1); + if (irc != 0) goto L140; + irc=kdiget_c(my_block2->ifile, &(my_block2->idir), c__2, c__1); + if (irc != 0) goto L140; + (*iplist)->idir = my_block2->idir; + xsmdir(&c__1,my_block2); + my_block2->modif = 0; + if (impx > 0) { + printf("%s: XSM FILE RECOVERY. FILE = '%s'.\n",nomsub,namp); + printf("%6s HIGHEST ATTAINABLE ADDRESS = %d\n"," ",(int)my_block2->ioft); + printf("%6s ACTIVE DIRECTORY = %s\n"," ",my_block2->mynam); + } + } else { +/* NEW-FILE MODE. */ + (*iplist)->impf = 1; + (*iplist)->idir = iprim; + my_block2->ioft = iprim+klong; + my_block2->idir = iprim; + my_block2->iroot = -1; + my_block2->nmt = 0; + my_block2->link = iprim; + sprintf(my_block2->mynam,"/"); + memcpy((char*)&ibuf,"$XSM",sizeof(ibuf)); + irc=kdiput_c(my_block2->ifile, &ibuf, c__0, c__1); + if (irc != 0) goto L150; + irc=kdiput_c(my_block2->ifile, &(my_block2->ioft), c__1, c__1); + if (irc != 0) goto L150; + irc=kdiput_c(my_block2->ifile, &(my_block2->idir), c__2, c__1); + if (irc != 0) goto L150; + xsmdir(&c__2,my_block2); + my_block2->modif = 1; + } + return; +L140: + sprintf(AbortString,"%s: kdiget_c ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,namp); + xabort_c(AbortString); +L150: + sprintf(AbortString,"%s: kdiput_c ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,namp); + xabort_c(AbortString); +} + +void xsmrep(const char *namt, int_32 *ind, int_32 *idir, block2 *my_block2, int_32 *iii) +/* + *----------------------------------------------------------------------- + * + * find a block (record or directory) position in the active directory + * and related extents. + * + * input parameters: + * namt : character*12 name of the required block. + * ind : =1 search namt ; =2 search and positionning in an empty + * slot of the active directory if namt does not exists. + * idir : offset of active directory on xsm file. + * my_block2 : address of memory-resident xsm structure (block 2). + * + * output parameter: + * iii : return code. =0 if the block named namt does not exists; + * =position in the active directory extent if namt extsts. + * =0 or 1 if namt=' '. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmrep"; + int_32 i, ipos, ipos2, irc, irc2, istart; + char namp[13],nomC[25]; + + if (my_block2->idir != *idir) { +/* SWITCH TO THE CORRECT ACTIVE DIRECTORY (BLOCK 2). */ + if (my_block2->modif == 1) xsmdir(&c__2, my_block2); + my_block2->idir = *idir; + xsmdir(&c__1, my_block2); + } + if (strcmp(namt,"***HANDLE***") == 0) { + sprintf(AbortString,"%s: ***HANDLE*** IS A RESERVED KEYWORD.",nomsub); + xabort_c(AbortString); + } + strcpy(namp,namt); + if (strcmp(namp," ") == 0) strcpy(namp,"***HANDLE***"); + ipos = -1; + if (my_block2->nmt < iofmax) ipos = my_block2->idir; + if (my_block2->nmt == 0) goto L50; + for (i = 1; i <= my_block2->nmt; ++i) { + if (strcmp(namp,my_block2->cmt[i-1]) == 0) { +/* THE BLOCK ALREADY EXISTS. */ + *iii = i; + return; + } + } +/* THE BLOCK NAMP DOES NOT EXISTS IN THE ACTIVE DIRECTORY EXTENT. WE + SEARCH IN OTHER EXTENTS THAT BELONG TO THE ACTIVE DIRECTORY. */ + if (my_block2->idir != my_block2->link) { +/* RECOVER A NEW DIRECTORY EXTENT. */ + istart = my_block2->link; + if (my_block2->modif == 1) xsmdir(&c__2, my_block2); + my_block2->idir = istart; +L30: + xsmdir(&c__1, my_block2); + if (my_block2->nmt < iofmax) ipos = my_block2->idir; + for (i = 1; i <= my_block2->nmt; ++i) { + if (strcmp(namp,my_block2->cmt[i-1]) == 0) { +/* THE BLOCK NAMP WAS FOUND IN THE ACTIVE DIRECTORY EXTENT. */ + *iii = i; + return; + } + } + if (my_block2->link == istart) goto L50; + my_block2->idir = my_block2->link; + goto L30; + } +L50: + *iii = 0; + if (*ind == 1) return; + if (ipos >= 0 && ipos != my_block2->idir) { +/* AN EXTENT WITH AN EMPTY SLOT WAS FOUND. */ + if (my_block2->modif == 1) xsmdir(&c__2, my_block2); + my_block2->idir = ipos; + xsmdir(&c__1, my_block2); + } else if (ipos == -1) { +/* THE ACTIVE DIRECTORY IS FULL. CREATE AN EXTENT. */ + ipos = my_block2->link; + my_block2->link = my_block2->ioft; + if (my_block2->modif == 1) { + xsmdir(&c__2, my_block2); + } else { + ipos2 = my_block2->idir + 3; + irc=kdiput_c(my_block2->ifile, &(my_block2->link), ipos2, c__1); + if (irc != 0) goto L150; + } + my_block2->idir = my_block2->link; + my_block2->link = ipos; + my_block2->ioft += klong; + my_block2->nmt = 0; + } + ++my_block2->nmt; + *iii = my_block2->nmt; + my_block2->modif = 1; + my_block2->jlon[*iii - 1] = 0; + my_block2->jtyp[*iii - 1] = 99; + strcpy(my_block2->cmt[*iii - 1],namp); + return; + +L150: + irc2=kdicl_c(my_block2->ifile, c__1); + strcpy(nomC,(my_block2->ifile)->nom); + if (irc2 != 0) printf("%s: kdicl_c ERROR NB. %d ON XSM FILE '%s'.\n",nomsub,(int)irc2,nomC); + sprintf(AbortString,"%s: kdiput_c ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,nomC); + xabort_c(AbortString); +} + +void xsmput_c(xsm **iplist, const char *namp, int_32 ilong, int_32 itype, int_32 *data1) +/* + *----------------------------------------------------------------------- + * + * copy a block from memory into the xsm file. + * + * input parameter: + * iplist : address of the handle to the xsm file. + * namp : character*12 name of the current block. + * ilong : number of information elements stored in the current block. + * itype : type of information elements stored in the current block. + * 0: directory 1: integer + * 2: single precision 3: character*4 + * 4: double precision 5: logical + * 6: complex + * data1 : information elements. dimension data1(ilong) + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmput_c"; + char nomC[13]; + block2 *my_block2; + int_32 iii,irc; + if ((*iplist)->impf == 2) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' IS OPEN IN READ-ONLY MODE(1).", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if (ilong <= 0) { + sprintf(AbortString,"%s: INVALID LENGTH (%d) FOR NODE '%s' IN THE XSM FILE '%.60s'.", + nomsub,(int)ilong,namp,(*iplist)->hname); + xabort_c(AbortString); + } else if (itype <= 0 || itype >= 8) { + sprintf(AbortString,"%s: INVALID TYPE NUMBER (%d) FOR NODE '%s' IN THE XSM FILE '%.60s'.", + nomsub,(int)itype,namp,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2=(*iplist)->ibloc; + xsmrep(namp, &c__2, &(*iplist)->idir, my_block2, &iii); + my_block2->modif = 1; + int_32 jlong = ilong; + if (itype == 4 || itype == 6) jlong = 2*ilong; + if (jlong > my_block2->jlon[iii-1]) { + my_block2->iofs[iii-1] = my_block2->ioft; + my_block2->ioft += jlong; + } + my_block2->jlon[iii-1] = jlong; + my_block2->jtyp[iii-1] = itype; + irc=kdiput_c(my_block2->ifile, data1, my_block2->iofs[iii-1], jlong); + if (irc != 0) { + strcpy(nomC,(my_block2->ifile)->nom); + sprintf(AbortString,"%s: kdiput_c ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,nomC); + xabort_c(AbortString); + } + return; +} +void xsmget_c(xsm **iplist, const char *namp, int_32 *data2) +/* + *----------------------------------------------------------------------- + * + * copy a block from the xsm file into memory. + * + * input parameters: + * iplist : address of the handle to the xsm file. + * namp : character*12 name of the current block. + * + * output parameter: + * data2 : information elements. dimension data2(ilong) + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmget_c"; + char nomC[13]; + block2 *my_block2; + int_32 iii,irc; + if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2=(*iplist)->ibloc; + xsmrep(namp, &c__1, &(*iplist)->idir, my_block2, &iii); + if (iii > 0) { + irc=kdiget_c(my_block2->ifile, data2, my_block2->iofs[iii-1], my_block2->jlon[iii-1]); + if (irc != 0) { + strcpy(nomC,(my_block2->ifile)->nom); + sprintf(AbortString,"%s: kdiget_c ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,nomC); + xabort_c(AbortString); + } + } else { + sprintf(AbortString,"%s: UNABLE TO FIND BLOCK '%s' INTO DIRECTORY '%s' IN THE XSM FILE '%.45s'.", + nomsub,namp,my_block2->mynam,(*iplist)->hname); + xabort_c(AbortString); + } + return; +} + +void xsmcl_c(xsm **iplist, int_32 istatu) +/* + *----------------------------------------------------------------------- + * + * close the xsm file. + * + * input parameters: + * iplist : address of the handle to the xsm file. + * istatu : =1 to keep the file at close ; =2 to destroy it. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmcl_c"; + block2 *my_block2; + int_32 i, irc, iii; + db1 *ipkeep; + db2 *ipkep2; + if ((*iplist)->impf == 2 && istatu == 2) { + sprintf(AbortString,"%s: CANNOT ERASE THE XSM FILE '%.60s' OPEN IN READ-ONLY MODE.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if (istatu < 1 || istatu > 2) { + sprintf(AbortString,"%s: INVALID ACTION ( %d ) ON XSM FILE '%s'.", + nomsub,(int)istatu,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + ipkeep = (*iplist)->icang; + if (ipkeep->nad > 0) { + for (i = 1; i <= ipkeep->nad; ++i) free(ipkeep->idir[i-1]); + free(ipkeep->idir); + } + ipkep2 = (*iplist)->icang2; + if (ipkep2->nad > 0) { + for (i = 1; i <= ipkep2->nad; ++i) free(ipkep2->iofset[i-1]); /* rlsara_c() */ + free(ipkep2->iref); + free(ipkep2->iofset); + free(ipkep2->lg); + } + my_block2 = (*iplist)->ibloc; + + if (my_block2->modif == 1) { + if ((*iplist)->impf == 2) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' IS OPEN IN READ-ONLY MODE(2).", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + xsmdir(&c__2, my_block2); + } + + if (my_block2->idir != (*iplist)->idir) { +/* SWITCH TO THE CORRECT ACTIVE DIRECTORY (BLOCK 2). */ + my_block2->idir = (*iplist)->idir; + xsmdir(&c__1, my_block2); + } + if (my_block2->iroot != -1) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' IS NOT ON ROOT DIRECTORY.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + if (my_block2->idir != iprim) { +/* SWITCH TO THE CORRECT ACTIVE DIRECTORY (BLOCK 2). */ + my_block2->idir = iprim; + xsmdir(&c__1, my_block2); + } + + irc = kdiget_c(my_block2->ifile, &iii, c__1, c__1); + if (irc != 0) goto L140; + if (my_block2->ioft > iii) { + if ((*iplist)->impf == 2) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' IS OPEN IN READ-ONLY MODE(3).", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + irc = kdiput_c(my_block2->ifile, &(my_block2->ioft), c__1, c__1); + if (irc != 0) goto L150; + } + irc = kdicl_c(my_block2->ifile, istatu); + if (irc != 0) goto L160; + +/* RELEASE THE XSM FILE HANDLE. */ + free((*iplist)->icang); + free((*iplist)->icang2); + my_block2->ifile = NULL; + free(my_block2); + (*iplist)->header = 0; + free(*iplist); + *iplist = NULL; + return; + +L140: + sprintf(AbortString,"%s: kdiget_c ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,(*iplist)->hname); + xabort_c(AbortString); +L150: + sprintf(AbortString,"%s: kdiput_c ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,(*iplist)->hname); + xabort_c(AbortString); +L160: + sprintf(AbortString,"%s: kdicl_cS ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,(*iplist)->hname); + xabort_c(AbortString); +} + +void xsmnxt_c(xsm **iplist, char *namp) +/* + *----------------------------------------------------------------------- + * + * find the name of the next block stored in the active directory. + * + * input parameters: + * iplist : address of the handle to the xsm file. + * namp : character*12 name of a block. if namp=' ' at input, find + * any name for any block stored in this directory. + * + * output parameters: + * namp : character*12 name of the next block. namp=' ' for an empty + * directory. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmnxt_c"; + block2 *my_block2; + int_32 iii; + + if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2 = (*iplist)->ibloc; + if (strcmp(namp," ") == 0) { + if (my_block2->idir != (*iplist)->idir) { +/* SWITCH TO THE CORRECT ACTIVE DIRECTORY (BLOCK 2). */ + if (my_block2->modif == 1) xsmdir(&c__2, my_block2); + my_block2->idir = (*iplist)->idir; + xsmdir(&c__1, my_block2); + } + iii = min(my_block2->nmt,1); + } else { + xsmrep(namp, &c__1, &(*iplist)->idir, my_block2, &iii); + } + if (iii == 0 && strcmp(namp, " ") == 0) { +/* EMPTY DIRECTORY */ + sprintf(AbortString,"%s: THE ACTIVE DIRECTORY '%s' OF THE XSM FILE '%.45s' IS EMPTY.", + nomsub,my_block2->mynam,(*iplist)->hname); + xabort_c(AbortString); + } else if (iii == 0) { + sprintf(AbortString,"%s: UNABLE TO FIND BLOCK '%s' INTO DIRECTORY '%s' IN THE XSM FILE '%.45s'.", + nomsub,namp,my_block2->mynam,(*iplist)->hname); + xabort_c(AbortString); + } else if (iii + 1 <= my_block2->nmt) { + strcpy(namp,my_block2->cmt[iii]); + return; + } +/* SWITCH TO THE NEXT DIRECTORY. */ + if (my_block2->idir != my_block2->link) { + if (my_block2->modif == 1) xsmdir(&c__2, my_block2); + my_block2->idir = my_block2->link; +/* RECOVER THE NEXT DIRECTORY. */ + xsmdir(&c__1, my_block2); + } + strcpy(namp,my_block2->cmt[0]); + if (strcmp(namp,"***HANDLE***") == 0) strcpy(namp," "); + return; +} + +void xsmlen_c(xsm **iplist, const char *namp, int_32 *ilong, int_32 *itype) +/* + *----------------------------------------------------------------------- + * + * return the length and type of a block. Return 0 if the block does not + * exists. + * + * input parameters: + * iplist : address of the handle to the xsm file. + * namp : character*12 name of the current block. + * ilong : number of information elements stored in the current block. + * ilong=-1 is returned for a scalar directory. + * ilong=0 if the block does not exists. + * itype : type of information elements stored in the current block. + * 0: directory 1: integer + * 2: single precision 3: character*4 + * 4: double precision 5: logical + * 6: complex 99: undefined + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmlen_c"; + block2 *my_block2; + int_32 iii; + if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2=(*iplist)->ibloc; + xsmrep(namp, &c__1, &(*iplist)->idir, my_block2, &iii); + if (iii > 0) { + *ilong = my_block2->jlon[iii-1]; + *itype = my_block2->jtyp[iii-1]; + if (*itype == 4 || *itype == 6) *ilong=*ilong/2; + } else { + *ilong = 0; + *itype = 99; + } + return; +} +void xsminf_c(xsm **iplist, char *namxsm, char *nammy, int_32 *empty, int_32 *ilong, int_32 *access) +/* + *----------------------------------------------------------------------- + * + * recover global informations related to an xsm file. + * + * input parameters: + * iplist : address of the handle to the xsm file. + * + * output parameters: + * namxsm : character*12 name of the xsm file. + * nammy : charecter*12 name of the active directory. + * empty : =.true. if the active directory is empty. + * ilong : =-1: for a table; >0: number of list items. + * access : type of access. =1: object open for modification; + * =2: object in read-only mode. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsminf_c"; + block2 *my_block2; + if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2=(*iplist)->ibloc; + if (my_block2->idir != (*iplist)->idir) { +/* SWITCH TO THE CORRECT ACTIVE DIRECTORY (BLOCK 2). */ + if (my_block2->modif == 1) xsmdir(&c__2, my_block2); + my_block2->idir = (*iplist)->idir; + xsmdir(&c__1, my_block2); + } + strcpy(namxsm,(*iplist)->hname); + strcpy(nammy,my_block2->mynam); + + *empty = (my_block2->nmt == 0); + *ilong = (*iplist)->listlen; + *access = (*iplist)->impf; + return; +} + +void xsmsix_c(xsm **iplist, const char *namp, int_32 iact) +/* + *----------------------------------------------------------------------- + * + * move in the scalar hierarchical structure of a xsm file. + * + * input parameters: + * iplist : address of the father/son table. + * namp : character*12 name of the son table if iact=1. + * not used if iact=0 or iact=2. + * iact : type of movement in the hierarchical structure. + * 0: move back to the root directory; + * 1: move to a son vectorial directory; + * 2: move back to the parent directory. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmsix_c"; + block2 *my_block2; + int_32 iii, lenold, idir=0, ityold; + xsm *iofset, *iofpre; + char nomC[13]; + + if (iact < 0 || iact > 2) { + sprintf(AbortString,"%s: INVALID ACTION (%d) ON THE XSM FILE '%.60s'.", + nomsub,(int)iact,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + if (iact == 1) { +/* MOVE TO A SON DIRECTORY. */ + my_block2=(*iplist)->ibloc; + xsmrep(namp, &c__2, &(*iplist)->idir, my_block2, &iii); + lenold = my_block2->jlon[iii-1]; + if (lenold == -1) lenold = 1; + ityold = my_block2->jtyp[iii-1]; + if (lenold == 0) { +/* CREATE A NEW SCALAR DIRECTORY EXTENT ON THE XSM FILE. */ + if ((*iplist)->impf == 2) { + printf("new directory name=%s\n",namp); + sprintf(AbortString,"%s: THE XSM FILE '%.60s' IS OPEN IN READ-ONLY MODE(4).", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2->jlon[iii-1] = -1; + my_block2->jtyp[iii-1] = 0; + my_block2->iofs[iii-1] = my_block2->ioft; + idir = my_block2->iofs[iii-1]; + my_block2->ioft += klong; + xsmdir(&c__2, my_block2); + my_block2->iroot = my_block2->idir; + strcpy(my_block2->mynam,namp); + my_block2->idir = my_block2->iofs[iii-1]; + my_block2->nmt = 0; + my_block2->link = my_block2->idir; + my_block2->modif = 1; + } else if (lenold == 1 && ityold == 0) { + idir = my_block2->iofs[iii-1]; + } else if (ityold != 0) { + sprintf(AbortString,"%s: BLOCK '%s' IS NOT A DIRECTORY OF THE XSM FILE '%.60s'.", + nomsub,namp,(*iplist)->hname); + xabort_c(AbortString); + } + iofset = (xsm *) malloc(sizeof(*iofset)); + +/* COPY BLOCK1 */ + iofset->header = (*iplist)->header; + strcpy(iofset->hname,(*iplist)->hname); + iofset->listlen = -1; + iofset->impf = (*iplist)->impf; + iofset->idir = (*iplist)->idir; + iofset->ibloc = (*iplist)->ibloc; + iofset->icang = (*iplist)->icang; + iofset->icang2 = (*iplist)->icang2; + iofset->father = (*iplist)->father; + + xsmkep(iofset->icang, c__1, &iofset); + iofset->idir = idir; + iofset->father = *iplist; + *iplist = iofset; + } else if (iact == 0 || iact == 2) { +/* MOVE BACK TO THE ROOT OR PARENT DIRECTORY. */ +L50: + my_block2 = (*iplist)->ibloc; + if (my_block2->modif == 1) xsmdir(&c__2, my_block2); + if (my_block2->idir != (*iplist)->idir) { +/* SWITCH TO THE CORRECT ACTIVE DIRECTORY (BLOCK 2). */ + my_block2->idir = (*iplist)->idir; + xsmdir(&c__1, my_block2); + } + if (my_block2->iroot == -1) { + if (iact == 0) { + if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: WRONG HEADER(1).",nomsub); + xabort_c(AbortString); + } + return; + } + sprintf(AbortString,"%s: THE XSM FILE '%.60s' IS ALREADY ON ROOT DIRECTORY.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + strcpy(nomC,my_block2->mynam); + iofset = *iplist; + *iplist = (*iplist)->father; + xsmrep(nomC, &c__1, &(*iplist)->idir, my_block2, &iii); + if (iii == 0) { + sprintf(AbortString,"%s: UNABLE TO STEP DOWN ON FATHER RECORD '%s' FOR XSM FILE '%.60s'.", + nomsub,namp,(*iplist)->hname); + xabort_c(AbortString); + } + iofpre = iofset; + xsmkep((*iplist)->icang, c__2, &iofpre); + free(iofset); + if (iact == 0 && (*iplist)->idir != iprim) { + goto L50; + } else if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: WRONG HEADER(2).",nomsub); + xabort_c(AbortString); + } + } + return; +} + +void xsmdid_c(xsm **iplist, const char *namp, xsm **jplist) +/* + *----------------------------------------------------------------------- + * + * create/access a daughter associative table in a father table. + * + * input parameters: + * iplist : address of the father table. + * namp : character*12 name of the daughter associative table. + * + * output parameter: + * jplist : address of the daughter associative table. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmdid_c"; + block2 *my_block2; + int_32 iii, lenold, idir=0, ityold; + xsm *iofset; + + if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2=(*iplist)->ibloc; + xsmrep(namp, &c__2, &(*iplist)->idir, my_block2, &iii); + lenold = my_block2->jlon[iii-1]; + ityold = my_block2->jtyp[iii-1]; + if (lenold == 0) { +/* CREATE A NEW SCALAR DIRECTORY EXTENT ON THE XSM FILE. */ + if ((*iplist)->impf == 2) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' IS OPEN IN READ-ONLY MODE(5).", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2->jlon[iii-1] = -1; + my_block2->jtyp[iii-1] = 0; + my_block2->iofs[iii-1] = my_block2->ioft; + idir = my_block2->iofs[iii-1]; + my_block2->ioft += klong; + xsmdir(&c__2, my_block2); + my_block2->iroot = my_block2->idir; + strcpy(my_block2->mynam,namp); + my_block2->idir = my_block2->iofs[iii-1]; + my_block2->nmt = 0; + my_block2->link = my_block2->idir; + my_block2->modif = 1; + } else if (lenold == -1 && ityold == 0) { + idir = my_block2->iofs[iii-1]; + } else { + sprintf(AbortString,"%s: BLOCK '%s' IS NOT AN ASSOCIATIVE TABLE OF THE XSM FILE '%.60s'.", + nomsub,namp,(*iplist)->hname); + xabort_c(AbortString); + } + iofset = (xsm *) malloc(sizeof(*iofset)); + *jplist = iofset; + +/* COPY BLOCK1 */ + (*jplist)->header = (*iplist)->header; + strcpy((*jplist)->hname,(*iplist)->hname); + (*jplist)->listlen = -1; + (*jplist)->impf = (*iplist)->impf; + (*jplist)->idir = idir; + (*jplist)->ibloc = (*iplist)->ibloc; + (*jplist)->icang = (*iplist)->icang; + (*jplist)->icang2 = (*iplist)->icang2; + (*jplist)->father = *iplist; + xsmkep((*iplist)->icang, c__1, &iofset); + return; +} + +void xsmlid_c(xsm **iplist, const char *namp, int_32 ilong, xsm **jplist) +/* + *----------------------------------------------------------------------- + * + * create/access the hierarchical structure of a list in a xsm file. + * + * input parameters: + * iplist : address of the father table. + * namp : character*12 name of the daughter list. + * ilong : dimension of the daughter list. + * + * output parameter: + * jplist : address of the daughter list. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmlid_c"; + char nomC[13]; + block2 *my_block2; + int_32 iii, irc, irc2, lenold, idir=0, i, idiold, ityold, iroold, *iivec; + xsm *iofset; + + if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if (ilong <= 0) { + sprintf(AbortString,"%s: INVALID LENGTH (%d) FOR NODE '%s' IN THE XSM FILE '%.60s'.", + nomsub,(int)ilong,namp,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2=(*iplist)->ibloc; + xsmrep(namp, &c__2, &(*iplist)->idir, my_block2, &iii); + lenold = my_block2->jlon[iii-1]; + ityold = my_block2->jtyp[iii-1]; + if ((ilong > lenold && ityold == 10) || lenold == 0) { +/* CREATE ILONG-LENOLD NEW LIST EXTENTS ON THE XSM FILE. */ + if ((*iplist)->impf == 2) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' IS OPEN IN READ-ONLY MODE(6).", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2->jlon[iii-1] = ilong; + my_block2->jtyp[iii-1] = 10; + idiold = my_block2->iofs[iii-1]; + my_block2->iofs[iii-1] = my_block2->ioft; + idir = my_block2->iofs[iii-1]; + my_block2->ioft += ilong; + iroold = my_block2->idir; + xsmdir(&c__2, my_block2); + iivec = (int_32 *) malloc(ilong * sizeof(*iivec)); + if (lenold > 0) { + irc = kdiget_c(my_block2->ifile, iivec, idiold, lenold); + if (irc != 0) goto L110; + } + for (i = abs(lenold) + 1; i <= ilong; ++i) { + iivec[i-1] = my_block2->ioft; + my_block2->iroot = iroold; + strcpy(my_block2->mynam,namp); + my_block2->nmt = 0; + my_block2->idir = my_block2->ioft; + my_block2->ioft += klong; + my_block2->link = my_block2->idir; + xsmdir(&c__2, my_block2); + } + irc = kdiput_c(my_block2->ifile, iivec, idir, ilong); + if (irc != 0) goto L100; + free(iivec); + } else if (ilong <= lenold && ityold == 10) { + ilong = lenold; + idir = my_block2->iofs[iii-1]; + } else if (ityold != 10) { + sprintf(AbortString,"%s: BLOCK '%s' IS NOT A LIST OF THE XSM FILE '%.60s'.", + nomsub,namp,(*iplist)->hname); + xabort_c(AbortString); + } + iivec = (int_32 *) malloc(ilong * sizeof(*iivec)); + irc = kdiget_c(my_block2->ifile, iivec, idir, ilong); + if (irc != 0) goto L110; + *jplist = (xsm *) malloc(ilong * sizeof(**jplist)); + for (i = 0; i < ilong; ++i) { + iofset = *jplist + i; + +/* COPY BLOCK1 */ + iofset->header = (*iplist)->header; + strcpy(iofset->hname,(*iplist)->hname); + iofset->listlen = 0; + iofset->impf = (*iplist)->impf; + iofset->idir = iivec[i]; + iofset->ibloc = (*iplist)->ibloc; + iofset->icang = (*iplist)->icang; + iofset->icang2 = (*iplist)->icang2; + iofset->father = *iplist; + } + (*jplist)->listlen = ilong; + xsmkep((*iplist)->icang, c__1, jplist); + free(iivec); + return; + +L100: + irc2=kdicl_c(my_block2->ifile, c__1); + strcpy(nomC,(my_block2->ifile)->nom); + if (irc2 != 0) printf("%s: kdicl_c ERROR NB. %d ON XSM FILE '%s'.\n",nomsub,(int)irc2,nomC); + sprintf(AbortString,"%s: kdiput_c ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,nomC); + xabort_c(AbortString); +L110: + irc2=kdicl_c(my_block2->ifile, c__1); + if (irc2 != 0) printf("%s: kdicl_c ERROR NB. %d ON XSM FILE '%s'.\n",nomsub,(int)irc2,nomC); + strcpy(nomC,(my_block2->ifile)->nom); + sprintf(AbortString,"%s: kdiget_c ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,nomC); + xabort_c(AbortString); +} + +void xsmgpd_c(xsm **iplist, const char *namp, int_32 **iofdum) +/* + *----------------------------------------------------------------------- + * + * get a malloc pointer for an entry in the xsm file. + * + * input parameters: + * iplist : address of the handle to the xsm file. + * namp : character*12 name of the current block. + * + * output parameter: + * iofdum : malloc pointer to the xsm entry named namp. + * + *----------------------------------------------------------------------- + */ +{ + db2 *ipkep2; + int_32 i, i0, ilong, itylcm, n; + xsmlen_c(iplist,namp,&ilong,&itylcm); + if(itylcm == 4 || itylcm == 6) ilong = 2*ilong; + ipkep2 = (*iplist)->icang2; + n = ipkep2->nad; + for (i = n; i >= 1; --i) { + if (ipkep2->iref[i-1] == iofdum) { + i0 = i; + goto L10; + } + } + goto L20; +L10: + if (ilong == ipkep2->lg[i0-1]) { + *iofdum = ipkep2->iofset[i0-1]; + xsmget_c(iplist,namp,*iofdum); + return; + } + free(ipkep2->iofset[i0-1]); /* rlsara_c() */ + for (i = i0; i <= n-1; ++i) { + ipkep2->iref[i-1]=ipkep2->iref[i]; + ipkep2->iofset[i-1]=ipkep2->iofset[i]; + ipkep2->lg[i-1]=ipkep2->lg[i]; + } + --ipkep2->nad; + n = ipkep2->nad; +L20: + *iofdum = (int_32 *)malloc(ilong*sizeof(int_32)); /* setara_c(ilong) */ + xsmget_c(iplist,namp,*iofdum); + if (n + 1 > ipkep2->maxad) { + int_32 ***my_iref, **my_iofset, *my_lg; + ipkep2->maxad += maxit; + my_iref = (int_32 ***) malloc((ipkep2->maxad)*sizeof(*my_iref)); + my_iofset = (int_32 **) malloc((ipkep2->maxad)*sizeof(*my_iofset)); + my_lg = (int_32 *) malloc((ipkep2->maxad)*sizeof(*my_lg)); + for (i = 0; i < n; ++i) { + my_iref[i]=ipkep2->iref[i]; + my_iofset[i]=ipkep2->iofset[i]; + my_lg[i]=ipkep2->lg[i]; + } + if (n > 0) { + free(ipkep2->iref); + free(ipkep2->iofset); + free(ipkep2->lg); + } + ipkep2->iref=my_iref; + ipkep2->iofset=my_iofset; + ipkep2->lg=my_lg; + } + ipkep2->iref[n] = iofdum; + ipkep2->iofset[n] = *iofdum; + ipkep2->lg[n] = ilong; + ++ipkep2->nad; + return; +} + +void xsmppd_c(xsm **iplist, const char *namp, int_32 ilong, int_32 itype, int_32 *iofdum) +/* + *----------------------------------------------------------------------- + * + * add a new malloc pointer entry in the xsm file. + * + * input parameter: + * iplist : address of the handle to the xsm file. + * namp : character*12 name of the current block. + * ilong : number of information elements stored in the current block. + * itype : type of information elements stored in the current block. + * 0: directory 1: integer + * 2: single precision 3: character*4 + * 4: double precision 5: logical + * 6: complex + * iofdum : malloc pointer of the first information element. + * + *----------------------------------------------------------------------- + */ +{ + db2 *ipkep2; + int_32 i, i0, n; + xsmput_c(iplist,namp,ilong,itype,iofdum); + ipkep2 = (*iplist)->icang2; + n = ipkep2->nad; + for (i = n; i >= 1; --i) { + if (ipkep2->iofset[i-1] == iofdum) { + i0 = i; + goto L10; + } + } + goto L20; +L10: + for (i = i0; i <= n-1; ++i) { + ipkep2->iref[i-1]=ipkep2->iref[i]; + ipkep2->iofset[i-1]=ipkep2->iofset[i]; + ipkep2->lg[i-1]=ipkep2->lg[i]; + } + --ipkep2->nad; + if (ipkep2->nad == 0) { + free(ipkep2->iref); + free(ipkep2->iofset); + free(ipkep2->lg); + ipkep2->maxad = 0; + ipkep2->iref = NULL; + ipkep2->iofset = NULL; + ipkep2->lg = NULL; + } +L20: + free(iofdum); /* rlsara_c(iofdum) */ + iofdum = NULL; + return; +} |