Exemplo n.º 1
0
int numlines(char *name)
// number of lines   no comments or blanks
{
    FILE *fff ;
    char line[MAXSTR] ;
    char *spt[MAXSTR] ;
    char *sx ;
    int nsplit, num=0 ;

    num = 0;
    if (name == NULL) fatalx("(numlines)  no name")  ;
    openit(name, &fff, "r") ;
    while (fgets(line, MAXSTR, fff) != NULL)  {
        nsplit = splitup(line, spt, MAXFF) ;
        if (nsplit==0) continue ;
        sx = spt[0] ;
        if (sx[0] == '#') {
            freeup(spt, nsplit) ;
            continue ;
        }
        ++num ;
        freeup(spt, nsplit) ;
    }
    fclose(fff) ;
    return num ;
}
Exemplo n.º 2
0
int numcols(char *name)
// number of cols 
{
  FILE *fff ;
  char line[MAXSTR] ;
  char *spt[MAXSTR] ;
  char *sx ;
  int nsplit ;

  if (name == NULL) fatalx("(numlines)  no name")  ;
  openit(name, &fff, "r") ;
  while (fgets(line, MAXSTR, fff) != NULL)  {
   nsplit = splitup(line, spt, MAXFF) ; 
   if (nsplit==0) continue ;
   sx = spt[0] ;
   if (sx[0] == '#') {
    freeup(spt, nsplit) ;
    continue ;
   }
   freeup(spt, nsplit) ;
   fclose(fff) ;
   return nsplit ;
  }
  return 0; // empty file; should this be a fatal error?
}
Exemplo n.º 3
0
void flipsnps(char *fsname, SNP **snpm, int numsnps, int phasedmode) 
{
  FILE *fff ;
  char line[MAXSTR] ;
  char *spt[MAXFF] ;
  char *ss ;
  int nsplit, n, k ;
  SNP *cupt ; 

  if (fsname == NULL) return ;
  openit (fsname, &fff, "r") ;

  freesnpindex() ;

  while (fgets(line, MAXSTR, fff) != NULL)  {
    nsplit = splitup(line, spt, MAXFF) ; 
    if (nsplit==0) continue ;
    if (spt[0][0] == '#') { 
     freeup(spt, nsplit) ;
     continue ;
    }
    
     k = snpindex(snpm, numsnps, spt[0]) ;      
     if (k>=0) {
      flip1(snpm[k], phasedmode, flipreference) ;
     }
    freeup(spt, nsplit) ;
  }
  fclose (fff) ;
}
Exemplo n.º 4
0
void
isetprompt(void)
{
  nialptr     z;
  int         t;

  z = apop();
  if (kind(z) == phrasetype || kind(z) == chartype) { 
    /* return old prompt */
    apush(makephrase(prompt));
    /* get new prompt */
    if (kind(z) == phrasetype) {
      t = tknlength(z);
      if (t > MAXPROMPTSIZE)
        goto spout;
      strcpy(prompt, pfirstchar(z));
    }
    else if (kind(z) == chartype) {
      t = tally(z);
      if (t > MAXPROMPTSIZE)
        goto spout;
      strcpy(prompt, pfirstchar(z));
    }
  }
  else
    buildfault("arg to setprompt must be string or phrase");
  freeup(z);
  return;
spout:
  freeup(apop());            /* old prompt already stacked */
  buildfault("prompt too long");
}
Exemplo n.º 5
0
void flipstrand(char *fsname, SNP **snpm, int numsnps) 
// move alleles to opposite strand
{
  FILE *fff ;
  char line[MAXSTR] ;
  char *spt[MAXFF] ;
  char *ss ;
  int nsplit, n, k ;
  SNP *cupt ; 

  if (fsname == NULL) return ;
  openit (fsname, &fff, "r") ;

  freesnpindex() ;

  while (fgets(line, MAXSTR, fff) != NULL)  {
    nsplit = splitup(line, spt, MAXFF) ; 
    if (nsplit==0) continue ;
    if (spt[0][0] == '#') { 
     freeup(spt, nsplit) ;
     continue ;
    }
    
     k = snpindex(snpm, numsnps, spt[0]) ;      
     if (k>=0) {
      cupt = snpm[k] ;
      cupt -> alleles[0] = compbase(cupt -> alleles[0]) ;
      cupt -> alleles[1] = compbase(cupt -> alleles[1]) ;
     }
    freeup(spt, nsplit) ;
  }
  fclose (fff) ;
}
Exemplo n.º 6
0
/* sets various inter globals. The arg may be a phrase or string. 
   It is mapped to upper case to make the match.
*/
void
iset(void)
{
  char       *msg;
  nialptr     name = apop();

  if (equalsymbol(name, "SKETCH")) {
    msg = (sketch ? "sketch" : "diagram");
    sketch = true;
  }
  else if (equalsymbol(name, "DIAGRAM")) {
    msg = (sketch ? "sketch" : "diagram");
    sketch = false;
  }
  else if (equalsymbol(name, "TRACE")) {
    msg = (trace ? "trace" : "notrace");
    trace = true;
  }
  else if (equalsymbol(name, "NOTRACE")) {
    msg = (trace ? "trace" : "notrace");
    trace = false;
  }
  else if (equalsymbol(name, "DECOR")) {
    msg = (decor ? "decor" : "nodecor");
    decor = true;
  }
  else if (equalsymbol(name, "NODECOR")) {
    msg = (decor ? "decor" : "nodecor");
    decor = false;
  }
  else if (equalsymbol(name, "LOG")) {
    msg = (keeplog ? "log" : "nolog");
    if (keeplog == false) {
      keeplog = true;
    }
  }
  else if (equalsymbol(name, "NOLOG")) {
    msg = (keeplog ? "log" : "nolog");
    if (keeplog) {
      keeplog = false;
    }
  }
#ifdef DEBUG
  else if (equalsymbol(name, "DEBUG")) {
    msg = (debug ? "debug" : "nodebug");
    debug = true;
  }
  else if (equalsymbol(name, "NODEBUG")) {
    msg = (debug ? "debug" : "nodebug");
    debug = false;
  }
#endif
  else {
    apush(makefault("?unknown set type"));
    freeup(name);
    return;
  }
  apush(makephrase(msg));
  freeup(name);
}
Exemplo n.º 7
0
int readpopx(char *pname, char ***plists, int npops)  
// reads lists of npops pops on a line
{
 FILE *fff ; 
 char line[MAXSTR+1], c ;
 char *spt[MAXFF], *sx  ;
 char **pp ;
 int nsplit,  t, num = 0  ;

 openit(pname, &fff, "r") ;
 line[MAXSTR] = '\0' ;
 while (fgets(line, MAXSTR, fff) != NULL)  {
   nsplit = splitup(line, spt, MAXFF) ;
   if (nsplit == 0) continue ;
   sx = spt[0] ; 
   if (sx[0] == '#')  {  
    freeup(spt, nsplit) ;
    continue ;
   }
   if (nsplit < npops) fatalx("length mismatch %s\n", line) ;
   ZALLOC(plists[num], npops+1, char *) ;
   plists[num][npops] == NULL ;
   pp = plists[num] ;
   for (t=0; t<npops; ++t) {  
    pp[t] = strdup(spt[t]) ;
   }
   striptrail(line, '\n') ;
   lines[num] = strdup(line) ; 
   ++num ; 
   freeup(spt, nsplit) ;
  }
  fclose(fff) ;
  return num ;
}
Exemplo n.º 8
0
void lapack_zheev(int nn, dcmplx *AA, dreal *ww)
{
  int    lda, lwork, rsize, info;
  char   jobz = 'V', uplo = 'U';
  dreal  *rwork = NULL;
  dcmplx *work = NULL;
  
  lda = (1 > nn) ? 1 : nn;
  lwork = (1 > 2*nn-1) ? 1 : 2*nn-1;
  rsize = (1 > 3*nn-2) ? 1 : 3*nn-2;
  work = (dcmplx *) calloc(lwork, sizeof(dcmplx));
  check_mem(work, "work");
  rwork = (dreal *) calloc(rsize, sizeof(dreal));
  check_mem(rwork, "rwork");
  
  zheev_(&jobz, &uplo, &nn, AA, &lda, ww, work, &lwork, rwork, &info);
  
  freeup(rwork);
  freeup(work);
  
  return;
  
 error:
  if(rwork) freeup(rwork);
  if(work) freeup(work);
  abort();
}
Exemplo n.º 9
0
void
callwtjack(char *iname, char *oname) 
{
  FILE *ifile, *ofile ;
  char line[MAXSTR];
  char *sx;
  char *spt[MAXFF];
  int nsplit, len, i, k;
  char c;
 
  openit(iname, &ifile, "r") ;
  openit(oname, &ofile, "w") ;

  double *jwt, *jmean;
  
  /* output variable */
  double est, sig;   // NB
  est =0; sig=0;

  /*input variables */
  len = numlines(iname);
  ZALLOC(jwt, len, double);     
  ZALLOC(jmean, len, double);
  k = 0;

 /* read input file and store data */
  while (fgets(line,MAXSTR,ifile) != NULL)  
  {
	nsplit = splitup(line, spt, MAXFF);
	sx = spt[0];
	c = sx[0];
	if (c == '#') {
		freeup(spt, nsplit);
		continue;
	}
	
	jwt[k] = atof(spt[1]);
	jmean[k] = atof(spt[2]);
	//printf("mean: %9.3f len: %9.3f\n", jmean[k], jwt[k]) ;
	k++;
	freeup(spt, nsplit);
  }  
  len = k ;  // better style  who knows how numlines handles commas
 fclose(ifile) ;
 // printf("mean: %9.3f len: %d\n", mean, len) ;


 /*call weightjack */
	weightjack(&est, &sig, mean, jmean, jwt, len);
	fprintf(ofile,"%9.3f", est);	 	// d format ??
	fprintf(ofile,"%9.3f", sig);	 	
	fprintf(ofile,"\n");
	free(jmean);
	free(jwt);
 fclose(ofile) ;

 }
Exemplo n.º 10
0
int
getnamesstripcolon(char ****pnames, int maxrow, int numcol, char *fname, int lo, int hi)
{

// count is base 1
    char line[MAXSTR] ;
    char *spt[MAXFF] ;
    char *sx ;
    int nsplit, i, j, num=0, maxff, numcolp, lcount=0 ;
    FILE *fff ;
    int nbad = 0 ;
    char ***names ;

    names = *pnames ;
    if (fname == NULL) fff = stdin ;
    else {
        openit(fname, &fff, "r") ;
    }
    numcolp = numcol + 1 ;
    maxff = MAX(MAXFF, numcolp) ;

    while (fgets(line, MAXSTR, fff) != NULL)  {
        subcolon(line) ;
        nsplit = splitup(line, spt, maxff) ;
        if (nsplit == 0) {
            freeup(spt, nsplit) ;
            continue ;
        }
        sx = spt[0] ;
        if (sx[0] == '#') {
            freeup(spt, nsplit) ;
            continue ;
        }
        if (nsplit<numcol) {
            ++nbad ;
            if (nbad<10) printf("+++ bad line: nsplit: %d numcol: %d\n%s\n", nsplit, numcol, line) ;
            continue ;
        }
        ++lcount ;
        if ((lcount<lo) || (lcount>hi)) {
            freeup(spt, nsplit) ;
            continue ;
        }
        if (num>=maxrow) fatalx("too much data\n") ;
        for (i=0; i<numcol; i++)  {
            names[i][num] = strdup(spt[i]) ;
        }
        freeup(spt, nsplit) ;
        ++num ;
    }
    if (fname != NULL) fclose(fff) ;
    return num ;
}
Exemplo n.º 11
0
void
iloaddefs(void)
{
  nialptr     nm,
              x = apop();
  int         mode;

  /* get the file name as a Nial array */
  if (atomic(x) || kind(x) == chartype)
    nm = x;
  else if (kind(x) == atype)
    nm = fetch_array(x, 0);
  else {
    buildfault("invalid file name");
    freeup(x);
    return;
  }

  mode = 0;  /* default to silent mode */
  if (kind(x) == atype && tally(x) == 2) {
    /* argument has a mode filed, select it */
    nialptr     it = fetch_array(x, 1);

    if (kind(it) == inttype)
      mode = intval(it);
    if (kind(it) == booltype)
      mode = boolval(it);
  }

  /* try to put filename into gcharbuf */
  if (!ngetname(nm, gcharbuf)) {
    buildfault("invalid file name");
    freeup(x);
  }

  else 
  { /* check the extension as .ndf */
    check_ext(gcharbuf, ".ndf",NOFORCE_EXTENSION);
    freeup(x);      /* do freeup here so file name doesn't show in iusedspace */

    /* load the definition file */
    if (loaddefs(true, gcharbuf, mode)) {
      apush(Nullexpr);
    }
    else
      buildfault(errmsgptr); /* this is safe since call is from iloaddefs */
  }

#ifdef DEBUG
  memchk();
#endif
}
Exemplo n.º 12
0
void
iload(void)
{
  nialptr     x = apop();
  int         n = ngetname(x, gcharbuf);

  freeup(x);
  if (n == 0)
    buildfault("invalid file name");
  else {
    FILE       *f1;

    check_ext(gcharbuf, ".nws",FORCE_EXTENSION);
    f1 = openfile(gcharbuf, 'r', 'b');
    if (f1 == OPENFAILED) {
      buildfault("cannot open nws file");
      return;
    }
    wsfileport = f1;
    /* jump to do1command */
    longjmp(loadsave_env, NC_WS_LOAD);
  }

#ifdef DEBUG
  if (debug) {
    memchk();
    nprintf(OF_DEBUG, "after iload memchk\n");
  }
#endif
}
Exemplo n.º 13
0
static void tddmrg_zWblock_R2L(mat2d_dcmplx *Wvc)
{
  int    ndim, mdim, idim, idimR;
  dreal  error;
  size_t nlen;
  dreal  *eig = NULL;
  
  ndim = Wvc->nrow;
  mdim = Wvc->ncol;
  
  nlen = ndim*sizeof(dcmplx);
  
  eig = (dreal *) calloc(NdimR, sizeof(dreal));
  
  lapack_zheev(NdimR, Dmat_R2L->addr, eig);
  
  for(idimR = 0, error = 0.0; idimR < NdimR-mdim; ++idimR)
    error += eig[idimR];
  
  //if(Rank == Root) {
  //  printf("%s\n", tddmrglabel);
  //  printf("%s error = %15.5e\n", tddmrglabel, error);
  //}
  
  for(idim = 0; idim < mdim; ++idim) {
    idimR = NdimR-idim-1;
    memcpy(Wvc->ptr[idim], Dmat_R2L->ptr[idimR], nlen);
  }
  
  freeup(eig);
}
Exemplo n.º 14
0
int
getxxnamesf(char ***pnames, double **xx, int maxrow, int numcol, FILE *fff)
/**
like getxxnames but file already open
*/
{

#define MAXFF  50

    char line[MAXSTR] ;
    char *spt[MAXFF] ;
    char *sx ;
    int nsplit, i, j, num=0, maxff, numcolp ;
    int nbad = 0 ;
    char **names ;

    if (pnames != NULL) names = *pnames ;

    numcolp = numcol + 1 ;
    maxff = MAX(MAXFF, numcolp) ;

    while (fgets(line, MAXSTR, fff) != NULL)  {
        nsplit = splitup(line, spt, maxff) ;
        if (nsplit == 0) {
            freeup(spt, nsplit) ;
            continue ;
        }
        sx = spt[0] ;
        if (sx[0] == '#') {
            freeup(spt, nsplit) ;
            continue ;
        }
        if (names != NULL) names[num] = strdup(sx) ;
        if (nsplit<numcolp) {
            ++nbad ;
            if (nbad<10) printf("+++ bad line: nsplit: %d numcol: %d\n%s\n", nsplit, numcol, line) ;
            continue ;
        }
        if (num>=maxrow) fatalx("too much data\n") ;
        for (i=0; i<numcol; i++)  {
            xx[i][num]  = atof(spt[i+1]) ;
        }
        freeup(spt, nsplit) ;
        ++num ;
    }
    return num ;
}
Exemplo n.º 15
0
int
getxxnames(char ***pnames, double **xx, int maxrow, int numcol, char *fname)
{

    char line[MAXSTR] ;
    char *spt[MAXFF] ;
    char *sx ;
    int nsplit, i, j, num=0, maxff, numcolp ;
    FILE *fff ;
    int nbad = 0 ;
    char **names = NULL ;

    if (pnames != NULL) names = *pnames ;
    if (fname == NULL) fff = stdin ;
    else {
        openit(fname, &fff, "r") ;
    }
    numcolp = numcol + 1 ;
    maxff = MAX(MAXFF, numcolp) ;

    while (fgets(line, MAXSTR, fff) != NULL)  {
        nsplit = splitup(line, spt, maxff) ;
        if (nsplit == 0) {
            freeup(spt, nsplit) ;
            continue ;
        }
        sx = spt[0] ;
        if (sx[0] == '#') {
            freeup(spt, nsplit) ;
            continue ;
        }
        if (names != NULL) names[num] = strdup(sx) ;
        if (nsplit<numcolp) {
            ++nbad ;
            if (nbad<10) printf("+++ bad line: nsplit: %d numcol: %d\n%s\n", nsplit, numcol, line) ;
            continue ;
        }
        if (num>=maxrow) fatalx("too much data\n") ;
        for (i=0; i<numcol; i++)  {
            xx[i][num]  = atof(spt[i+1]) ;
        }
        freeup(spt, nsplit) ;
        ++num ;
    }
    if (fname != NULL) fclose(fff) ;
    return num ;
}
Exemplo n.º 16
0
nialptr
testbinfaults(nialptr x, nialptr stdfault, int divflag)
{
  nialptr     x0 = fetch_array(x, 0),
              x1 = fetch_array(x, 1);

  switch (kind(x0)) {
    case booltype:
    case inttype:
    case realtype:
        freeup(stdfault);
        return (x1);
    case chartype:
    case phrasetype: /* fall out to return stdfault */
        break;
    case faulttype:
        switch (kind(x1)) {
          case booltype:
              if (divflag && boolval(x1) == 0)
                break;
              freeup(stdfault);
              return (x0);
          case inttype:
              if (divflag && intval(x1) == 0)
                break;
              freeup(stdfault);
              return (x0);
          case realtype:
              if (divflag && realval(x1) == 0.0)
                break;
              freeup(stdfault);
              return (x0);
          case chartype:
          case phrasetype:
              break;
          case faulttype:
              if (x0 == x1) {
                freeup(stdfault);
                return (x0);
              }
              break;
        }
  }
  return (stdfault);
}
Exemplo n.º 17
0
nialptr
arithconvert(nialptr x, int *newk)
{
  int         k,
              ki,
              changed;
  nialint     i,
              t = tally(x);
  nialptr     z,
              x0,
              xi;

  if (t == 0) { /* x is empty */
    *newk = kind(x);
    return (x);
  }

  /* set k based on kind of first item */
  x0 = fetch_array(x, 0);    /* first item */
  k = kind(x0);

  /* loop to find maximum kind in x */
  for (i = 1; i < t; i++) {  
    xi = fetch_array(x, i);
    ki = kind(xi);
    if (ki > k)
      k = ki;
  }

  /* convert to highest kind */
  changed = true;
  if (homotype(k) && k != chartype) {
    switch (k) {
      case inttype:
          z = to_int(x);
          break;

      case realtype:
          z = to_real(x);
          break;
      default:

          z = x;
          changed = false;
          break;
    }
  }
  else {
    z = x;
    changed = false;
  }

  if (changed)               /* argument has been converted */
    freeup(x);
  *newk = k;
  return (z);
}
Exemplo n.º 18
0
// Inverse of matrix AA
void lapack_dinvs(int nn, dreal *AA)
{
  int *ipiv = NULL;
  
  ipiv = (int *) calloc(nn, sizeof(int));
  check_mem(ipiv, "ipiv");
  
  lapack_dgetrf(nn, nn, AA, ipiv);
  lapack_dgetri(nn, AA, ipiv);
  
  freeup(ipiv);
  
  return;
  
 error:
  if(ipiv) freeup(ipiv);
  abort();
}
Exemplo n.º 19
0
int
getss(char **ss, char *fname)
/**
 get list of names
*/
{

    char line[MAXSTR] ;
    char qqq[MAXSTR] ;
    char *spt[MAXFF] ;
    char *sx ;
    int nsplit, i, j, num=0, maxff ;
    FILE *fff ;


    if (fname == NULL) fff = stdin ;
    else {
        openit(fname, &fff, "r") ;
    }
    maxff = MAXFF  ;

    while (fgets(line, MAXSTR, fff) != NULL)  {
        nsplit = splitup(line, spt, maxff) ;
        if (nsplit == 0) {
            freeup(spt, nsplit) ;
            continue ;
        }
        sx = spt[0] ;
        if (sx[0] == '#') {
            freeup(spt, nsplit) ;
            continue ;
        }
        if (nsplit<1) {
            continue ;
        }
        ss[num] = strdup(spt[0]) ;
        freeup(spt, nsplit) ;
        ++num ;
    }
    if (fname != NULL) fclose(fff) ;
    return num ;
}
Exemplo n.º 20
0
void lapack_dsyev(int nn, dreal *AA, dreal *ww)
{
  int   lda, lwork, info;
  char  jobz = 'V', uplo = 'U';
  dreal *work = NULL;
  
  lda = (1 > nn) ? 1 : nn;
  lwork = (1 > 3*nn-1) ? 1 : 3*nn-1;
  work = (dreal *) calloc(lwork, sizeof(dreal));
  check_mem(work, "work");
  
  dsyev_(&jobz, &uplo, &nn, AA, &lda, ww, work, &lwork, &info);
  
  freeup(work);
  
  return;
  
 error:
  if(work) freeup(work);
  abort();
}
Exemplo n.º 21
0
void lapack_dsteqr(int nn, int ldz, dreal *alph, dreal *beta, dreal *zz)
{
  int   nwork, info;
  char  compz = 'I';
  dreal *work = NULL;
  
  nwork = (1 >= 2*nn-2) ? 1 : 2*nn-2;
  
  work = (dreal *) calloc(nwork, sizeof(dreal));
  check_mem(work, "work");
  
  dsteqr_(&compz, &nn, alph, beta, zz, &ldz, work, &info);
  
  freeup(work);
  
  return;
  
 error:
  if(work) freeup(work);
  abort();
}
Exemplo n.º 22
0
// Interface to lapack routine dgetri
// nn: nrow and ncol of A
void lapack_dgetri(int nn, dreal *AA, int *ipiv)
{
  int   lda, lwork, info;
  dreal *work = NULL;
  
  lda = (1 > nn) ? 1 : nn;
  lwork = lda;
  
  work = (dreal *) calloc(lwork, sizeof(dreal));
  check_mem(work, "work");
  
  dgetri_(&nn, AA, &lda, ipiv, work, &lwork, &info);
  check(info == 0, "Failed dgetri, info = %d", info);
  
  freeup(work);
  
  return;
  
 error:
  if(work) freeup(work);
  abort();
}
Exemplo n.º 23
0
void
iedit(void)
{
  nialptr     nm = apop();

  if (ngetname(nm, gcharbuf) == 0)
    buildfault("invalid_name");
  else {
    calleditor(gcharbuf);
    apush(Nullexpr);
  }
  freeup(nm);
}
Exemplo n.º 24
0
void numeric_kronig(int ngrd, dcmplx *gg, dcmplx *kk)
{
  int    ig;
  dcmplx *fr = NULL, *ff = NULL;
  
  check(ngrd % 2 == 0, "Invalid ngrd");
  
  fr = (dcmplx *) calloc(ngrd, sizeof(dcmplx));
  check_mem(fr, "fr");
  ff = (dcmplx *) calloc(ngrd, sizeof(dcmplx));
  check_mem(ff, "ff");
  
  for(ig = 0; ig < ngrd/2; ++ig) {
    fr[ig]        = gg[ig+ngrd/2];
    fr[ig+ngrd/2] = gg[ig];
  }
  
  fourier_dcmplx_1d(ngrd, fr, ff, fourier_forward);
  
  ff[0] *= 0.5; // Removing plateau
  for(ig = 0; ig < ngrd / 2; ++ig) {
    ff[ig+ngrd/2] = 0.0;
  }
  
  fourier_dcmplx_1d(ngrd, ff, fr, fourier_backward);
  
  for(ig = 0; ig < ngrd/2; ++ig) {
    kk[ig]        = fr[ig+ngrd/2] / ngrd;
    kk[ig+ngrd/2] = fr[ig] / ngrd;
  }
  
  freeup(ff); freeup(fr);
  
  return;
  
 error:
  abort();
}
Exemplo n.º 25
0
nialptr
getuppername()
{
  nialptr     x = apop();
  int         n = ngetname(x, gcharbuf);

  freeup(x);
  if (n == 0)
    return (grounded);
  else {
    cnvtup(gcharbuf);
    return (makephrase(gcharbuf));
  }
}
Exemplo n.º 26
0
static void tddmrg_expMat(dreal tau, const mat2d_dreal *Mat, mat2d_dcmplx *expMat)
{
  int    ndim, idim, jdim;
  dreal  *mat = NULL, *eig = NULL;
  dcmplx *zmat = NULL, *expdiag = NULL, *tmpmat = NULL;
  
  ndim = Mat->nrow;
  
  expMat->Reset(expMat);
  
  mat = (dreal *) calloc(ndim*ndim, sizeof(dreal));
  eig = (dreal *) calloc(ndim, sizeof(dreal));
  
  zmat    = (dcmplx *) calloc(ndim*ndim, sizeof(dcmplx));
  expdiag = (dcmplx *) calloc(ndim*ndim, sizeof(dcmplx));
  tmpmat  = (dcmplx *) calloc(ndim*ndim, sizeof(dcmplx));
  
  memcpy(mat, Mat->addr, ndim*ndim*sizeof(dreal));
  
  lapack_dsyev(ndim, mat, eig);
  
  for(idim = 0; idim < ndim; ++idim)
    for(jdim = 0; jdim < ndim; ++jdim)
      zmat[idim*ndim+jdim] = (dcmplx) mat[idim*ndim+jdim];
  
  for(idim = 0; idim < ndim; ++idim)
    expdiag[idim*ndim+idim] = cexp(-I * eig[idim] * tau);
  
  lapack_zgemm(ndim, ndim, ndim, 'N', 'C', 1.0, expdiag, zmat, 0.0, tmpmat); 
  lapack_zgemm(ndim, ndim, ndim, 'N', 'N', 1.0, zmat, tmpmat, 0.0, expMat->addr); 
  
  freeup(tmpmat);
  freeup(expdiag);
  freeup(zmat);
  freeup(eig);
  freeup(mat);
}
Exemplo n.º 27
0
nialptr
testfaults(nialptr x, nialptr stdfault)
{
  int         found = false;
  nialint     t = tally(x),
              i = 0;
  nialptr     xi = Null,
              z;

  /* find first fault */
  while (!found && i < t) {
    xi = fetch_array(x, i++);
    if (kind(xi) == chartype || kind(xi) == phrasetype)
      return (stdfault);     /* result is stdfault if other literal types occur */
    found = kind(xi) == faulttype;

  }

  if (!found)
    return (stdfault);       /* used in "and" and "or" in cases like "and o -12" */

  z = xi;
#ifdef V4AT
  if (stdfault==Logical)
  { /* Logical faults are different in V4 */
    i = 0;  /* scan all the items */
    /* find other faults and compare */
    while (i < t) {
      xi = fetch_array(x, i++);
      if ((kind(xi) == faulttype && z != xi) || kind(xi) != faulttype)
         /* result is stdfault if fault value changes or other type */
        return (stdfault);
    }	
  }
  else
#endif

  /* find other faults and compare */
  { while (i < t) {
      xi = fetch_array(x, i++);
      if ((kind(xi) == faulttype && z != xi) || kind(xi) == chartype ||
          kind(xi) == phrasetype) /* result is stdfault if fault value changes
                                     or other literal type */
        return (stdfault);
    }
  }
  freeup(stdfault);   /* since this is a temporary and not used */
  return (z);
}
Exemplo n.º 28
0
nialptr
bool_to_real(nialptr x)
{
  nialint     i,
              t = tally(x);
  nialptr     z;
  double     *pz;
  int         v = valence(x);

  z = new_create_array(realtype, v, 0, shpptr(x, v));
  pz = pfirstreal(z);        /* safe */
  for (i = 0; i < t; i++)
    *pz++ = 1.0 * fetch_bool(x, i);
  freeup(x);
  return (z);
}
Exemplo n.º 29
0
void
ihost()
{
  nialptr     x = apop();

  if (ngetname(x, gcharbuf) == 0)
    buildfault("invalid host command");
  else {
    if (command(gcharbuf) == NORMALRETURN) {
      apush(Nullexpr);
    }
    else
      buildfault(errmsgptr);
  }
  freeup(x);
}
Exemplo n.º 30
0
int
convert(nialptr * x, int *kx, int k)
{
  if (numeric(k)) {
    nialptr     z = Null;
    int         v = valence(*x);
    nialint     i,
                t = tally(*x);

    switch (k) {
      case inttype:          /* must be converting a booltype array */
          {
            nialint    *zptr;

            z = new_create_array(inttype, v, 0, shpptr(*x, v));
            zptr = pfirstint(z);  /* safe */
            for (i = 0; i < t; i++)
              *zptr++ = fetch_bool(*x, i);
          }
          break; 

      case realtype: /* converting a boolean or integer array */
          {
            double     *zptr;

            z = new_create_array(realtype, v, 0, shpptr(*x, v));
            zptr = pfirstreal(z); /* safe */
            if (*kx == booltype) {
              for (i = 0; i < t; i++)
                *zptr++ = (double) fetch_bool(*x, i);
            }
            else {
              nialint    *xptr = pfirstint(*x); /* safe */

              for (i = 0; i < t; i++)
                *zptr++ = (double) *xptr++;
            }
          }
          break;
    }
    freeup(*x);
    *x = z;
    *kx = kind(z);
    return true;
  }
  return false;
}