/* This function is used to exactly duplicate the arrival array of doubles from
i to o.  If *o is not a null pointer it is assumed the arr already
exists and freearr is called to clear it's contents before 
calling setarr to copy contents.*/
void dup_arrival_array(Arr *in,Arr **o)
{
	Tbl *t;
	double *value,*copy;
	char *key;
	int i;

	if((*o) == NULL)
		*o = newarr(0);
	else
	{
		freearr(*o,free);
		*o=newarr(0);
	}

	t = keysarr(in);
	for(i=0;i<maxtbl(t);++i)
	{
		key = gettbl(t,i);
		value = (double *)getarr(in,key);
		allot(double *,copy,1);
		*copy = *value;
		setarr(*o,key,copy);
	}
	freetbl(t,0);
}
Exemplo n.º 2
0
Arquivo: symg.c Projeto: nhatcher/lie
static lie_Index n_parts(lie_Index n)
{ lie_Index i,k,np; entry* c=mkintarray(n+1); /* coefficients */
  if (n>121) error("Too many partitions to generate.\n");
  for (i=0; i<=n; ++i) c[i]=1; /* initialise to ${1\over1-X}$ */
  for (i=2; i<=n; ++i)
    for (k=i; k<=n; ++k) c[k]+=c[k-i]; /* multiply by ${1\over1-X^i}$ */
  np=c[n]; freearr(c); return np;
}
Exemplo n.º 3
0
poly* Vdecomp(poly* p)
{   lie_Index i,r=Lierank(grp);
    poly* result=poly_null(r);
    cur_expon=mkintarray(r); /* large enough */
    for (i=0; i<p->nrows; ++i)
        result=Addmul_pol_pol_bin(result,vdecomp_irr(p->elm[i]),p->coef[i]);
    freearr(cur_expon);
    return result;
}
Exemplo n.º 4
0
Arquivo: lr.c Projeto: d4g33z/lie
poly* LR_tensor_irr(entry* lambda,entry * mu, _index n)
{ _index i,j;
	entry* nu; entry** T;
  if (n==0) return poly_one(0);
  
  { nu=&mkintarray(n+1)[1]; copyrow(lambda,nu,n); nu[-1]=lambda[0]+mu[0];
  T=alloc_array(entry*,n+1);
    for (i=0;i<=n;++i) /* allocate row |T[i]| and place sentinel before it */
    	{ T[i]= &mkintarray(mu[i==0?0:i-1]+1)[1]; T[i][-1]=n-1-i; }
    for (i=0,j=mu[0]-1; j>=0; --j)
    { while (i<n && mu[i]>j) ++i; /* find first |i| with |mu[i]<=j| */
      T[i][j]=-1; /* place sentinel at bottom of column |j| */
    } 
  }
  wt_init(n); /* prepare to collect terms with exponents of size~|n| */

  
  { j=-1;  for (i=n-1; i>0 && mu[i]==0; --i) {} /* move to initial position */
  recurse: /* recursive starting point; */
    if (++j>=mu[i] &&(j=0,--i<0)) /* move to next empty position, if any */
      wt_ins(nu,one,false); /* if not, |T| is full; contribute |nu| once */
  else
    
    { _index k= T[i+1][j]; entry prev= nu[k];
      do
      { while (nu[++k]==prev) {} /* find next |k| with |nu[k]<nu[@t$k'$@>]| */
        ++nu[T[i][j]=k]; goto recurse;
          /* insert |k| into |T| and extend partition |nu|; recurse */
        resume: prev= --nu[k=T[i][j]];
          /* restore |k| and |nu|; set |prev=nu[k]| */
      } while (prev>nu[T[i][j-1]]);
          /* if so, there are still corners of |nu| to try */
    }
    if (j==0) j= ++i<n?mu[i]:0; /* return to end of row below if necessary */
    if (--j>=0) goto resume; /* do return jump unless empty row is reached */
  }
  
  { --nu; freearr(nu);
    for (i=0;i<=n;i++) { entry* t=&T[i][-1]; freearr(t); }
    freearr(T);
  }
  return wt_collect(); /* return sum of all contributed terms */
}
Exemplo n.º 5
0
Arquivo: weyl.c Projeto: nhatcher/lie
bigint* Orbitsize(entry* w)
{ lie_Index i,d,s=Ssrank(grp); entry* x=mkintarray(s),* y=x; bigint* result=one;
  copyrow(w,x,s); make_dominant(x);
  if (type_of(grp)==SIMPGRP) return simp_worbitsize(x,&grp->s);
  for (i=0; i<grp->g.ncomp; ++i,y+=d)
  { simpgrp* g=Liecomp(grp,i); d=g->lierank;
    result=mult(result,simp_worbitsize(y,g));
  }
  freearr(x); return result;
}
Exemplo n.º 6
0
Arquivo: symg.c Projeto: nhatcher/lie
entry Schur_char_val(entry* lambda, entry* mu, lie_Index l, lie_Index m)
{ lie_Index i; entry sum=0;
  while (l>0 && lambda[l-1]==0) --l; /* get reduced form of~|lambda| */
  
  if (l<=1) return 1; /* trivial character */
  if (l>lambda[0]) /* then better work with the transpose partition */
  { vector* tr=Trans_part(lambda,l);
    entry ch=Schur_char_val(tr->compon,mu,lambda[0],m); freemem(tr);
    return Sign_part(mu,m)*ch;
  }
  
  { entry* lambda_prime=mkintarray(4*l)
       ,* sigma=lambda_prime+l,* pos=sigma+l,* nu=pos+l;
      /* 4 length-|l| arrays */
    boolean sg=true; /* positive sign */
    copyrow(lambda,lambda_prime,l);
      /* |lambda| might be alias of |mu|, but |lambda_prime| is not */
    for (i=0; i<l; ++i) pos[i]=sigma[i]=i;
      /* |sigma| is the permutation; |pos| records its swap sequence */
    do
    { copyrow(lambda_prime,nu,l); 
                                  { lie_Index i; for (i=1; i<l; ++i) if (nu[i]>nu[i-1]) /* skip most cases */
                                    { entry nui=nu[i]; lie_Index j=i;
                                      do nu[j]=nu[j-1]; while (--j>0 && nui>nu[j-1]); nu[j]=nui;
                                    }
                                  }
      sum+= sg ? Young_char_val(nu,mu,l,m) : -Young_char_val(nu,mu,l,m);
      
      { lie_Index i=0,j;
        
        do
        { 
          { lambda_prime[i]-=sigma[i];
            if ((j=pos[i])<i) { swap(&sigma[i],&sigma[j]); sg=!sg;}
          }
          do
            if(--j<0) break; /* tried all positions for this |i| */
          while (lambda_prime[i]+sigma[j]<0);
        } while (j<0 && ++i<l);
        if (i==l) break;
        
        do /* now |j>=0| and |sigma[j]| can move validly to |sigma[i]| */
        { 
          { if ((pos[i]=j)<i) { swap(&sigma[i],&sigma[j]); sg=!sg;}
            lambda_prime[i]+=sigma[i]; /* this becomes non-negative */
          }
          if (--i<0) break;
          for (j=i; lambda_prime[i]+sigma[j]<0; --j) {} /* this leaves |j>=0| */
        } while (true);
      }
    } while (true);
    freearr(lambda_prime);
  }
  return sum;
}
Exemplo n.º 7
0
Arquivo: symg.c Projeto: nhatcher/lie
matrix* Partitions(lie_Index n)
{ matrix* result=mkmatrix(n_parts(n),n);
  if (n>0)
  { entry* lambda=mkintarray(n),** res=result->elm; lie_Index i=0,j;
    lambda[0]=n; 
    for(j=1;j<n;j++) lambda[j]=0; /* initialise |lambda| to $[n,0,0,\ldots]$ */
    do copyrow(lambda,res[i++],n); while(Nextpart(lambda,n));
    freearr(lambda);
  }
  return result;
}
Exemplo n.º 8
0
cmpfn_tp set_ordering (cmpfn_tp criterion, lie_Index n, object g)
{ if (criterion!=height_decr && criterion!=height_incr) return criterion;
  if (g==NULL || n!=Lierank(g))
    return criterion==height_decr ? deg_decr : deg_incr; /* substitute */
  if (level_vec==NULL
     || int_eq_grp_grp(g,level_vec_group)==(object)bool_false)
  { if (level_vec!=NULL) freearr(level_vec);
    level_vec=Lv(g); level_vec_group=g;
  }
  return criterion;
}
Exemplo n.º 9
0
Arquivo: prime.c Projeto: shixv/test
int main(int argc,char *argv[])
{
	if(argc<2)
		return 0;
	struct node *arr=NULL;
	int count=0;
	arr=CreatePrimeArray(atoi(argv[1]),&count);
//	writefile(arr);
	printf("%d\n",count);
	freearr(arr);
	return 0;
}
Exemplo n.º 10
0
Arquivo: symg.c Projeto: nhatcher/lie
matrix* Permutations(entry* v,lie_Index n)
{ lie_Index N=1; entry* w=mkintarray(n); copyrow(v,w,n); sortrow(w,n);
  { lie_Index i=0,j=n-1; while (i<j) swap(&w[i++],&w[j--]); }
    /* increasing order */
  
  { lie_Index i=0, mult=1;
    while (++i<n) { N*=i+1; if (w[i]>w[i-1]) mult=1; else N /= ++mult; }
  }
  { matrix* result=mkmatrix(N,n); lie_Index i=0;
    do copyrow(w,result->elm[i++],n); while (Nextperm(w,n));
    freearr(w); return result;
  }
}
Exemplo n.º 11
0
Arquivo: symg.c Projeto: nhatcher/lie
matrix* Tableaux(entry* lambda, lie_Index l)
{ bigint* nt=n_tableaux(lambda,l); lie_Index n=check_part(lambda,l);
  matrix* result=mkmatrix(bigint2entry(nt),n);
  entry** res=result->elm,* t=mkintarray(n);
  freemem(nt);

  
  { lie_Index i=0,j,k;
    for (j=1; j<=l; ++j) for (k=lambda[j-1]; k>0; --k) t[i++]=j;
  }
  { lie_Index i=0; do copyrow(t,res[i++],n); while(Nexttableau(t,n)); }
  freearr(t); return result;
}
Exemplo n.º 12
0
int 
main() {
	int **B;
	int i, j, k, sum, n;

	while (scanf("%d", &n) != -1 && n > 0) {
		A = alloc(n);
		B = alloc(n);
		for (i = 0; i < n; i++) {
			for (j = 0; j < n; j++) {
				scanf("%d", &A[i][j]);
			}
		}
		for (i = 0; i < n; i++) {
			for (j = 0; j < n; j++) {
				scanf("%d", &B[i][j]);
			}
		}

		for (i = 0; i < n; i++) {
			for (j = 0; j < n; j++) {
				sum = 0;
				for (k = 0; k < n; k++) {
					sum += A[i][k] * B[k][j];
				}
				printf("%d", sum);
				if (j == n - 1) {
					printf("\n");
				} else {
					printf(" ");
				}
			}
		}
		printf("\n");
		freearr(A, n);
		freearr(B, n);
	}
	return 0;
}
Exemplo n.º 13
0
Arquivo: symg.c Projeto: nhatcher/lie
bigint* n_tableaux(entry* lambda, lie_Index l)
{ lie_Index i,j,k=0; entry* h; bigint* res=copybigint(one,NULL);
  do  if (--l<=0) return one; 
  while (lambda[l]==0); /* find last non-zero part */
  h=mkintarray(lambda[0]); 
  for(j=0; j<lambda[0]; ++j) h[j]=0; /* accumulated column heigths */
  for(i=l; i>=0; --i)
    
    { entry li=lambda[i]-1;
      for(j=0; j<=li; ++j) res=mul1(res,++k); /* part of factorial */
      for(j=0; j<=li; ++j) div1(res,(++h[j])+li-j); /* divide by hook lengths */
    }
  freearr(h); return res;
}
Exemplo n.º 14
0
local void long_close(matrix* m, lie_Index first, lie_Index last)
{ lie_Index i,j;  entry* root_i,* root_j,* t=mkintarray(s);
  for (i=first; i<last; ++i)
  { root_i=m->elm[i]; if (Norm(root_i)>1) continue;
    for (j=i+1; j<last; ++j)
    { root_j=m->elm[j]; if (Norm(root_j)>1) continue;
      subrow(root_i,root_j,t,s);
      if (isroot(t))
	if (isposroot(t)) 
	{ copyrow(t,root_i,s); break;  } /* need not consider more |j|'s */
	else add_xrow_to(root_j,-1,root_i,s);
    }
  }
  freearr(t);
}
Exemplo n.º 15
0
local void fundam(matrix* roots, lie_Index first, lie_Index* last)
{ lie_Index i,j,d;  boolean changed;
  entry* t=mkintarray(s);  matrix mm,* m=&mm;
  mm.elm=&roots->elm[first]; mm.nrows=*last-first; mm.ncols=roots->ncols;
  for (i=m->nrows-1; i>0; changed ? Unique(m,cmpfn),i=m->nrows-1 : --i)
  { entry* root_i=m->elm[i]; changed=false;
    
    for (j=i-1; j>=0; j--)
    { entry* root_j=m->elm[j]; entry c=Cart_inprod(root_j,root_i);
      if (c==2 && eqrow(root_j,root_i,s))
        
        { cycle_block(m,j,m->nrows--,1); root_i=m->elm[--i];
        } 
      else if (c>0)
      { changed=true;
        
        { copyrow(root_j,t,s); add_xrow_to(t,-c,root_i,s);
          if (isposroot(t)) copyrow(t,root_j,s);
          else
          { j=i; c=Cart_inprod(root_i,root_j);
            copyrow(root_i,t,s); add_xrow_to(t,-c,root_j,s);
            if (isposroot(t)) copyrow(t,root_i,s);
            else 
                 { lie_Index k;  entry* ln,* sh; /* the longer and the shorter root */
                   if (Norm(root_i)>Norm(root_j))
                     ln=root_i, sh=root_j;  else ln=root_j, sh=root_i;
                   switch (Norm(ln))
                   { case 2: subrow(ln,sh,sh,s); /* |sh=ln-sh| */
                     add_xrow_to(ln,-2,sh,s); /* |ln=ln-2*sh| */
                   break; case 3: /* |grp=@t$G_2$@>| now */
                     for (k=0; sh[k]==0; ++k) {} /* find the place of this $G_2$ component */
                     sh[k]=1; sh[k+1]=0; ln[k]=0; ln[k+1]=1;
                       /* return standard basis of full system */
                   break; default: error("problem with norm 1 roots\n");
                   }
                 }
          }
        }
      }
    }
  }
  cycle_block(roots,first+mm.nrows,roots->nrows,d=*last-first-mm.nrows);
*last-=d; roots->nrows-=d;
  freearr(t);
}
Exemplo n.º 16
0
Arquivo: weyl.c Projeto: nhatcher/lie
poly* alt_Wsum(poly* p)
{ lie_Index i,k=0,r=p->ncols; poly* result; entry** res,*rho=mkintarray(r);
  p=Alt_dom(p); for (i=0; i<r; ++i) rho[i]=1;
  for (i=0; i<p->nrows; ++i) add_xrow_to(p->elm[i],1,rho,r);
  result=mkpoly(p->nrows*bigint2entry(Worder(grp)),r); res=result->elm;
  for (i=0; i<p->nrows; ++i)
  { lie_Index j,l; matrix* orbit=Weyl_orbit(p->elm[i],NULL); entry** x=orbit->elm;
    bigint* c=p->coef[i],* min_c=sub(null,c);
    for (j=0; j<orbit->nrows; ++j)
    { subrow(*x,rho,res[k],r); l=make_dominant(*x++)%2;
      result->coef[k]= l ? min_c : c; setshared(result->coef[k]); ++k;
    }
    freemem(orbit);
  }
  freearr(rho);
  assert(k==result->nrows);
  return result; /* not sorted, but rows are unique */
}
Exemplo n.º 17
0
void freevarlist(void) {
	varentry_t *next = varlist;

	if(next == NULL)
		return;

	do {
		free(varlist->ident);
		if(varlist->type == string) {
			free(varlist->val.string);
		} else if  ((varlist->type == strarr) ||
					(varlist->type == intarr) ||
					(varlist->type == decarr)) {
			freearr(varlist->val.array);
		}
		next = varlist->next;
		free(varlist);
		varlist = next;
	} while(varlist);
}
/* Edits the array of phase handles to keep only phases
named in the keeplist Tbl of phase names strings.  This
is complicated by the fact that keeplist is a simple
list.  The algorithm used converts the keeplist to a
temporary associative array then passes through the
array of phase handles calling the free routine on
phases not found in the keeplist.

Author:  G Pavlis
Written:  August 2001
*/
void edit_phase_handle(Arr *a,Tbl *keeplist)
{
    Tbl *akeys;
    Arr *akeeper;
    int dummy;  /* used purely as a placeholder in akeeper*/
    char *phase;
    int i,n;
    Phase_handle *ph;

    n = maxtbl(keeplist);
    if(n<=0)
        elog_die(0,"List of phases to keep is empty.\n\
Check phases_to_keep parameter setting\n");
    akeeper = newarr(0);
    for(i=0; i<maxtbl(keeplist); ++i)
    {
        phase = (char *)gettbl(keeplist,i);
        setarr(akeeper,phase,&dummy);
        ph = (Phase_handle *)getarr(a,phase);
        if(ph==NULL)elog_die(0,
                                 "Don't know how to handle required phase %s\n",
                                 phase);
    }
    akeys = keysarr(a);
    for(i=0; i<maxtbl(akeys); ++i)
    {
        phase = gettbl(akeys,i);
        if(getarr(akeeper,phase) == NULL)
        {
            ph = (Phase_handle *)getarr(a,phase);
            free_phase_handle(ph);
            delarr(a,phase);
        }
    }

    freearr(akeeper,0);
    freetbl(akeys,0);
}
Exemplo n.º 19
0
/* To avoid having station corrections on top of other station corrections
we need to make sure the station correction portion of each phase
handle is cleared.  This is done with a simple freearr on the station
correction associative array.

Arguments:  
	pha - associative array of phase handle keyed by phase name.

Author:  Gary Pavlis
Written:  October 2000
*/
void clear_station_corrections(Arr *pha)
{
	int i;
	Phase_handle *p;
	Tbl *keys;
	char *phase;

	keys = keysarr(pha);
	for(i=0;i<maxtbl(keys);++i)
	{

		phase = gettbl(keys,i);
		p = (Phase_handle *)getarr(pha,phase);
		if(cntarr(p->time_station_corrections)>0)
		{
			elog_notify(0,"Clearing time station correction for phase %s\nConsider editing your parameter file for this program\n",
				phase);
			freearr(p->time_station_corrections,free);
			p->time_station_corrections=newarr(0);

		}
	}
	freetbl(keys,0);
}
Exemplo n.º 20
0
/* This is the main processing function for this program.  

Arguments:
	dbv - db pointer to a complex view of the database to be 
		processed.  That is, it has these properties:
		1.  It is a join of:
			event->origin->assoc->arrival
		2.  subset to single arrival name AND orid==prefor
		3.  sorted by evid/sta

	pf - input parameter space

The main processing loop here keys on the grouping defined in the view
passed as dbgrp.  That is, seismograms for each event group are processed
as a complete gather.  After that, are nested loops to do the multiwavelet
processing as described in Bear and Pavlis (1999a,b).  

Author:  Gary Pavlis
Date:  March 1999+
*/
#define LAG_ERROR -100000 /* Computed lags smaller than this returned
			by compute_optimal_lag are treated as an error
			condition.  Should probably be in an include file*/
void mwap_process(Dbptr dbv,char *phase,  Pf *pf) 
{
	int nevents;  /* number of events=number of groups in dbgrp */
	MWbasis *mw;  /* Multiwavelet basis functions */
	Tbl **decimators;  /* List of loaded decimators used to construct
				multiwavelet transforms in lower bands */
        Tbl **dec_objects;  /*Actual decimation filter objects */
	/* Note:  mw and dec_objects define the multiwavelet transform */
	int nwavelets,nbands;

	/* sets coherence mode used to determine optimal lag */
	int coherence_type;
	
	Arr *stations;  /* This associative array holds MWstation objects
			that contain header like data that is station 
			dependent */
	Arr *badclocks;  /* associative array keyed by sta name holding
			list of time intervals with bad timing */
	char *refsta;  /* Name of reference station */
	double refelev;  /* reference elevation from parameter file */
	int nsta;  /* number of stations */
	int ntest;
	Dbptr db;  /* generic db lookup parameter */
	Dbptr dbgrp;  /* evid group db pointer */
	Dbptr tr;  /* trace database */
	Dbptr dbmps;  /* mwpredslow table */
	Tbl *sortkeys,*sortkeys2;  /* used because different tr routines require
				different sort orders */

	int *pad;  /* vector of length nbands holding computed time padding
			lengths for each band in samples */
	int tpad;  /*time pad actually used  (max of *pad) */
	Time_Window *swin, *nwin;  /* arrays defining time windows
		for signal and noise respectively (relative to arrival)*/
	Time_Window swinall, nwinall;  /*define read time intervals (extracted
			from swin and nwin arrays */
	int *decfac;  /* array of decimation factors needed at times */
	Arr *mwarr;  /* Holds indexed multiwavelet transformed trace objects*/
	/* We keep three copies of arrival time information.  
		arrival0 = original times read from db (never altered)
		arrivals = current working copy
		arrival_new = new estimate obtained from "arrivals" 
	*/
	Arr *arrival0,*arrivals,*arrival_new;
	Arr *static_result;  /* Holds error statistics for static estimates */
	MWSlowness_vector u0,u;
	int i,j;
	double avgamp, amperr;
	int ampndgf;
	int iterations;
	double ucovariance[9];
	char *array_name;
	int accumulate;

	/* These are channel code names used in trace library rotation
	functions rotate_to_standard and trrotate.  */
	char *stdchans[3]={ EW, NS , VERTICAL };
	char *pcchans[3]={"R","T","ZL"};

	Arr *mwsig_arr,*mwnoise_arr;  /* these index pointers to mw transformed
			signal and noise series */
	Arr **sn_ratios;  /* vector of Arr pointers of length nbands indexing
		signal to noise ratio estimates (stored in a structure) for
		every station */
	Spherical_Coordinate polarization0,polarization;
	Spherical_Coordinate polarz={1.0,0.0,0.0};
	Arr *model_times=NULL;
	MWSlowness_vector model_slow;
	double rctm[9];  /*ray coordinate transformation matrix*/
	double timeref;  /* time reference at reference station */
	double time;
	double t0,twin;
	double si;
	double fc,fwin;
	int evid;
	int lag;  /* optimal lab computed by coherence measure */
	double peakcm;  /*Peak value of coherence measure */
	/* For a given gather we set moveout computed moveout time in
	seconds relative to the reference station.  This time includes
	the combined current static estimates.  This is a vector workspace
	that is recycled for every gather.  It is alloced soon as we
	know the number of stations in the site table.  */
	double *moveout;
	MWgather **gathers;
	Particle_Motion_Ellipse *avgpm;
	Particle_Motion_Error *avgerr;
	char *pmtype_to_use;  /* type of particle motion estimate to use
				for polarization */
	Arr *pm_arr,*pmerr_arr;
	Arr *pmarray,*errarray;
	/* This vector defines the "up" direction.  For P waves this
	initialization is correct.  For S it may not be appropriate, but
	this is something to repair later */
	double up[3]={0.0,0.0,1.0};
	int bankid;  /* mutliwavelet group id */
	int band_exit = 0;
	/* name of parameter file produced by GUI to control this program */
	char *guipf;
	int stack_alignment;
	Pf *pfcontrol;
	int loopback;
	int numberpasses=0;
	/* These define the relative time window used for stack and
	particle motion.  s denotes stack, ts0 etc are pm */
	double sts0,ste0;  /* we don't need the equivalent of ts1 and te1 */
	double ts0,ts1,te1,te0;

	/* This is essential or copy_arrival_array can produce garbage */
	arrival0=NULL;
	arrivals = NULL;
	arrival_new=NULL;
	pm_arr = NULL;
	pmerr_arr = NULL;
	pmarray = NULL;
	errarray = NULL;
	si = pfget_double(pf,"sample_interval");
	/* First we need to load the multiwavelet functions and the 
	associated decimators for the transform.  Each of these
	routines will die if serious problems occur and have no
	error returns.  Wavelet functions can be loaded from a parameter
	file or a db.  */
	if(pfget_boolean(pf,"get_wavelets_from_database"))
	{	
		mw = load_multiwavelets_db(dbv,pf,&nwavelets,&bankid);
	}
	else
	{
        	mw = load_multiwavelets_pf(pf,&nwavelets);
		bankid = pfget_int(pf,"bankid");
	}
        decimators = define_decimation(pf,&nbands);
	allot(int *,decfac,nbands);
        dec_objects = build_decimation_objects(decimators,nbands,decfac);

	print_band_info(mw,decfac,pf);

	/* This creates the station objects.  The time extracted here
	is needed to sort out the ontime:endtime key in the site table.
	This is done is a less than bombproof fashion by randomly 
	grabbing the time in the first record view.
	Because of the way the site table works this will always work
	in some fashion.  It will only matter if a station ever moves
	and then we have a bad problem anyway.  */
	dbv.record = 0;
	dbgetv(dbv,0,"time",&time,0);
	stations = build_station_objects(dbv,pf,time);
	refsta = get_refsta(stations);
	array_name = pfget_string(pf,"array_name");
	if(array_name == NULL)
	{
		elog_complain(0,"WARNING:  array_name not defined in parameter file.  Set to default of ARRAY\n");
		array_name = strdup("ARRAY");

	}
	refelev = pfget_double(pf,"reference_elevation");
	/* This loads a definition of bad clocks from an extension
	table called timing.  This comes from libgenloc where it
	is used to handle automatic switching to S-P times. */
	badclocks=newarr(0);
	if(db_badclock_definition(dbv,pf,badclocks))
	{
		elog_notify(0,"Problems in setting up table of stations with timing problems\n");
	}
	/* This function can define stations as always having bad timing
	based on a parameter Tbl list of station names keyed by bad_clock.*/
	pfget_badclocks(pf,badclocks);

	pmtype_to_use = pfget_string(pf,"array_particle_motion_to_use");
	if(pmtype_to_use==NULL) pmtype_to_use=strdup(PMOTION_BEAM);
	/* this used to be a variable, but we no longer have a choice.*/
	coherence_type=USE_COHERENCE;
	
	/* This variable sets if we should reset the arrival estimates
	to starting values for each band.  When true the results accumulate
	from band to band.  That is we keep adding corrections from previous
	band to progressively higher frequency.*/
	accumulate = pfget_boolean(pf,"accumulate_statics");
	/* compute time pad lengths for each band of the mw transforms */
	pad = compute_tpad(dec_objects, mw, stations,pf);

	/* These routine parses the parameter file for noise and
	analysis time window information respectively returning
	arrays of Time_Window structures of length nbands*/
	decfac = get_decimation_factors(dec_objects, pf);
	swin = get_signal_windows(decfac,pad,pf);
	nwin = get_noise_windows(decfac,pad,pf);
	print_window_data(decfac,nbands,swin,nwin,pf);	

	/* This gets time windows for signal and noise needed for
	reading data (i.e. largest time ranges needed) */
	swinall = compute_time_window(swin,decfac,nbands);
	nwinall = compute_time_window(nwin,decfac,nbands);

	guipf = pfget_string(pf,"mwapcontrol");
	/* better safe than sorry */
	if(guipf==NULL)
	{
		elog_die(0,"Missing required parameter mwapcontrol");
	}

	/* We can create these works spaces now for efficiency so 
	we don't have to constantly recreate them dynamically below */
	allot(double *,moveout,cntarr(stations));
	allot(MWgather **,gathers,nwavelets);

	/* This associative array holds indexed pointers to multiwavelet
	transformed traces.  We create it here, but it is repeatedly
	freed and cleared below */
	mwarr = newarr(0);
	/* This one has to be initialized*/
	static_result=newarr(0);

	/* We need this table repeatedly below so we avoid constant 
	lookups */
	dbmps = dblookup(dbv,0,"mwpredslow",0,0);
	if(dbmps.record == dbINVALID)
		elog_die(0,"db lookup failed for mwpredslow table\nMWavelet schema extensions are required\n");

	/* Now we loop through the outer loop event by event.  
	This is structured here by using a dbgroup defined db pointer
	that is passed through the argument list.  The db pointer 
	is incremented and then the bundle is taken apart to crack
	apart each group of traces (the gather).  Note we use
	a defined name to look up the evid grouped table. */
	dbgrp = dblookup(dbv,0,EVIDBDLNAME,0,0);
	if (dbgrp.record == dbINVALID)
		elog_die(0,"Error in dblookup for named evid group table = %s\n",
			EVIDBDLNAME);
        dbquery(dbgrp,dbRECORD_COUNT,&nevents);
        fprintf(stdout,"Processing begins for %d events\n",nevents);

	sortkeys = newtbl(0);
	pushtbl(sortkeys,"sta");
	pushtbl(sortkeys,"chan");
	pushtbl(sortkeys,"time");
	sortkeys2 = newtbl(0);
	pushtbl(sortkeys2,"time");
	pushtbl(sortkeys2,"sta");
	pushtbl(sortkeys2,"chan");

	for(dbgrp.record=0;dbgrp.record<nevents;++dbgrp.record)
	{
		Dbptr db_bundle;
		int evid; 
		int is, ie; 
		int ierr;
		double modaz;

		if(dbgetv(dbgrp,0,"evid", &evid,
                        "bundle", &db_bundle,0) == dbINVALID)
		{
                        elog_complain(1,"dbgetv error for row %d of event group\nAttempting to continue by skipping to next event\n",
                                dbgrp.record);
			continue;
		}

                dbget_range(db_bundle,&is,&ie);

		if(ie-is<3)
		{
			elog_complain(0,"Insufficient data to process for evid %d\nNeed at least three station -- found only %d\n",
				evid,ie-is);
			continue;
		}
		/* We utilize what we call plane wave statics here
		to approximately correct for wavefront curvature.
		We set the record number to is so we can access 
		the correct origin information from the db.  Because
		we used a join allrows of this group should have the
		same origin data.  */
		ierr = set_pwstatics(stations,refsta,phase,db_bundle,pf);
		if(ierr)elog_complain(0,"%d errors computing %d plane wave statics for evid %d\n",
			ierr,ie-is,evid);

		/* This routine loads an Arr of arrival times from 
		the input db to be used to compute initial slowness
		vector and initial statics.  */
		arrival0 = get_arrivals(db_bundle);

		/* We edit the MWstation array to flag stations
		with bad timing in this function */
		MWcheck_timing(arrival0,stations,badclocks);

		/* Save these times */
		copy_arrival_array(arrival0,&arrivals);


		/* Initialize slowness vector to 0 and then estimate
		it from data using current arrival times */
		u0.ux = 0.0;  u0.uy = 0.0;  u0.refsta = refsta;
		timeref = compute_time_reference(stations,arrivals,refsta,u0);
		/* for the first pass we use weights defined for the 
		lowest frequency band.  This is done because it asssumed
		that if frequency dependent weighting is actually used
		the lowest band would have the widest effective aperture. */
		ierr = estimate_slowness_vector(u0,arrivals,stations,
			refsta, refelev, timeref, phase, nbands-1,&u);
		/* It is necessary to reset the time reference to handle 
		the case correctly when the reference station does not
		actually record this event.  This function uses a moveout
		correction that depends upon the slowness vector, so it can
		float about a bit in that situation */
		if(ierr>0)
			elog_notify(0,"%d nonfatal errors in estimate_slowness_vetor for evid %d\n",ierr,evid);
		else if(ierr < 0)
		{
			elog_complain(0,"estimate_slowness_vector failed for initial slowness estimate for evid %d\nData for this event will be skipped\n",
				evid);
			continue;
		}
		/* This routine returns the slowness vector and an arr of 
		estimated arrival times.  The slowness vector is saved
		in the mwpredslow table immediately below.  Arrival times
		are used to compute residuals later. */
		ierr = MWget_model_tt_slow(stations, refsta, phase,
			db_bundle, pf, &model_times, &model_slow);

		timeref = compute_time_reference(stations,arrivals,refsta,u);
		polarization0=estimate_initial_polarization(model_slow,stations,
			refsta,phase);

		modaz = atan2(model_slow.ux,model_slow.uy);

		if(dbaddv(dbmps,0,"sta",array_name,
			"evid",evid,
			"phase",phase,
			"time",timeref,
			"slo",hypot(model_slow.ux,model_slow.uy),
			"azimuth",deg(modaz),
			"majoraz",deg(polarization0.phi),
			"majorema",deg(polarization0.theta),
			"vmodel",pfget_string(pf,"TTmodel"),0) == dbINVALID)
		{
			elog_complain(0,"dbaddv error for evid %d on mwpredslow table\n",
				evid);
		}

		/* This function reads in the trace data for this event
		using time windows defined above */
		tr = mwap_readdata(dbgrp,arrivals,swinall, nwinall);
		if(tr.record == dbINVALID)
		{
			elog_complain(0,"Serious problems reading data for evid %d -- no data processed for this event\n",evid);
			continue;
		}
		tr = dblookup(tr,0,"trace",0,0);
		/* We first glue together any possible recording break
		generated entries -- common with continuous data.
		This also seems to require a resort because of the
		way data was read in.   */
/*
		tr = dbsort(tr,sortkeys,0,0);
*/
		trsplice(tr,0.1,0,0);

		/* We run trsplit to break up waveform segments at real gaps.
		I'm not sure later code will work correctly if it isn't an 
		all or nothing situations (e.g. gap in Z component, but 
		not in N or E).  In any case, we have to deal with 
		potential multiple segments later.  */
		trsplit(tr,0,0);

		trapply_calib(tr);
		trdemean_seg(tr);
		/* Now we have reorder the traces or this will not work
		correctly*/
		tr = dbsort(tr,sortkeys2,0,0);
		ierr = rotate_to_standard(tr,stdchans);
		if(ierr<0)
		{
			elog_complain(0,"rotate_to_standard failed processing evid %d -- no data processed for this event\n",
				evid);
			continue;
		}
		if(ierr>0)elog_complain(0,"rotate_to_standard failed for %d stations\n",
				ierr);

		/* This releases the space held by the raw data traces
		keeping only the rotate_to_standard outputs */
		free_noncardinal_traces(tr);

		elog_log(0,"Computing multiwavelet transform:  be\
 patient as this can take a while with many channels\n");
		/* This function computes the multiwavelet transform
		of all traces currently in tr for signals around arrival*/
		mwsig_arr = tr_mwtransform(tr,arrivals,swin,decfac,dec_objects,
				nbands,mw,nwavelets);

		/* We repeat the same thing for noise windows */
		mwnoise_arr = tr_mwtransform(tr,arrivals,nwin,decfac,
				dec_objects,nbands,mw,nwavelets);
		/* Now compute signal to noise ratio figures for all
		nbands storing the structures that define the results
		in an Arr keyed by station. Note this is actually 
		a vector of Arr pointers of length nbands.  Further
		note the following function creates this complicated
		object, and it must be freed after each event is 
		processed. */
		sn_ratios=compute_signal_to_noise(mwsig_arr,mwnoise_arr,
					stations,arrivals,swin,nwin,
					nbands,nwavelets);

		/* Now we get to the heart of this program.  This is
		the outer loop over frequency.  Note the loop goes
		backward because the lowest frequencies are the final
		row of the mw transform matrices of pointers */

		copy_MWslowness_vector(&u,&u0);
		if(numberpasses>0)
		{
			fprintf(MWpout,"NEWEVENT %d\n",evid);
		}
		for(i=nbands-1;i>=0;--i)
		{
			if(!accumulate)
				copy_arrival_array(arrival0,&arrivals);

			copy_arrival_array(arrivals,&arrival_new);
			fc = (mw[i].f0)/(2.0*si*decfac[i]);
			fwin = (mw[i].fw)/(2.0*si*decfac[i]);

			fprintf(stdout,"Processing begins on band %d with center frequency %lf\nWait for -Hit Accept button when ready- prompt\n",
				i,fc);

			/* This builds the basic working gathers for
			each wavelet and builds a shortcut of pointers
			to MWtraces that are related */
			for(j=0;j<nwavelets;++j)
			{
				gathers[j] = build_MWgather(i,j,
						mwsig_arr,stations,
						sn_ratios[i],pf);
			}
			fprintf(stdout,"Working gather for this band has %d stations\n",
				gathers[0]->nsta);
			/* Testing band 0 should be sufficient.  The
			signal-to-noise is averaged overall wavelets so
			the same stations should be deleted in all
			wavelet of the group */
			if(gathers[0]->nsta < 3)
			{
				elog_notify(0,"Insufficient data in band %d to passed signal-to-noise cutoff defined for this band for evid %d\nSkipping to next frequency band\n",
					i,evid);
				continue;
			}
			/* This may not be necessary, but it is certainly 
			important for debugging.  We check that all
			the gathers in the group have the same length.  
			If they aren't, we are in trouble because we use
			a single vector to hold moveout information */
			check_gather_consistency(gathers,nwavelets);

			/* Now we compute the moveout information assuming
			stations are in the same order in the gather for
			each wavelet */
			if(compute_total_moveout(*gathers,stations,refsta,
				u,refelev,phase,moveout))
			{
				elog_die(0,"Cannot find reference station to compute moveout:  Should not happen unless program overwrites itself\n");
			}

			if(numberpasses>0)
			{
				fprintf(MWpout,"NEWBAND %d\n",i);
				fflush(MWpout);
			}
			else
			{
				char ctmp[40];
				fprintf(stdout,"Starting processing of first event\nSelect and options and press the Start button when ready\n");
				fprintf(MWpout,"STARTUP %d %d\n", 
					evid,i);
				fflush(MWpout);
				fgets(ctmp,40,MWpin);
			}
			++numberpasses;

			/* This is placed here to allow changing the
			alignment options on the fly.  Choice may
			depend on data. */
			pfread(guipf,&pfcontrol);
			stack_alignment=get_stack_align_mode(pfcontrol);
			pffree(pfcontrol);
			
			/* kind of a odd loop construct here made 
			necessary by differences in stackalignment
			options.  If we align with theoretical value
			or use the vertical we do not need to repeat
			this loop and we fall out the bottom.  If we
			use the pm estimate, however, we have to 
			realign the stack rotated to the new major
			ellipse estimate.  In that case we have to
			repeat the whole procedure.*/
			loopback=2;
			do {
				MWstack *stack;
				switch(stack_alignment)
				{
				case PMTHEORY:
					copy_polarization(&polarization0,&polarization);
					loopback=0;
					break;
				case PMZ:
					copy_polarization(&polarz,&polarization);
					loopback=0;
					break;
				case PMESTIMATE:
				default:
				/* This uses theoretical version for the
				first pass then the estimate on the 
				second */
					if(loopback==2)
					  copy_polarization(&polarization0,
						&polarization);
				}
				stack=MWcompute_arrival_times(gathers,
    					   nwavelets,timeref,moveout,
    					   polarization,swin[i],
					   sn_ratios[i],guipf,
    					   &arrival_new,&static_result,
                                            &avgamp, &amperr, &ampndgf);
				if(stack==NULL)
				{
					/* I use a flag to avoid an
					evil goto here */
					band_exit = 1;
					/* This is strange but necessary
					to stop string of bogus errors from
					copy_arrival_array function when
					this loops back */
					if(arrival_new!=NULL)
						freearr(arrival_new,free);
					arrival_new = NULL;

					break;
				}
					
					
				/* Note this routine updates residual
				static values to new values relative to
				the new slowness vector estimate */
	                	ierr = estimate_slowness_vector(u0,
					arrival_new,stations,
                        		refsta, refelev, timeref, 
					phase, i, &u);
				/* We need to recompute the moveout to 
				now be relative to the new slowness vector
				estimate.  We then use this for particle 
				motion analysis which can change the 
				polarization vector */
				compute_total_moveout(*gathers,stations,refsta,
				u,refelev,phase,moveout);
				/* This segment converts particle motions
				for 3-c arrays.  */
				if(gathers[0]->ncomponents==3)
				{
					MWstack *spm; 
					Time_Window pmtwindow;
					double *timeweight;
					
					/* We extract the time window
					from a control parameter file which
					is assumed to be created by a GUI
					with tcl/tk */
					pfread(guipf,&pfcontrol);
					ts0=pfget_double(pfcontrol,"pm_ts0");
					ts1=pfget_double(pfcontrol,"pm_ts1");
					te1=pfget_double(pfcontrol,"pm_te1");
					te0=pfget_double(pfcontrol,"pm_te0");
					/* we need these below, not here */
					sts0=pfget_double(pfcontrol,"stack_ts0");
					ste0=pfget_double(pfcontrol,"stack_te0");
					twin = ste0-sts0;
					pffree(pfcontrol);
					pmtwindow.tstart = nint(ts0/(stack->dt));
					pmtwindow.tend = nint(te0/(stack->dt));

					spm = MWextract_stack_window(stack,
						&pmtwindow);
					if(spm==NULL)
						elog_die(0,
						  "Fatal error in MWextract_stack_window\n");
					/* Sets time weight function for 
					a trapezoidal window */
					timeweight=MWstack_set_trapezoidal_window(spm->tstart,
						spm->dt,spm->nt,
						ts0,ts1,te1,te0);
					dcopy(spm->nt,timeweight,1,spm->timeweight,1);
					free(timeweight);
					MWstack_apply_timeweight(spm);

					if(MWcompute_array_particle_motion(gathers,
					  nwavelets,spm,timeref,moveout,
					  up,&pmarray,&errarray, &pm_arr,&pmerr_arr) )
					{
					  elog_complain(0,"Errors in MWcompute_array_particle_motion\n");
					}
					avgpm = (Particle_Motion_Ellipse *)getarr(pmarray,pmtype_to_use);
					avgerr = (Particle_Motion_Error *)getarr(pmarray,pmtype_to_use);

					polarization
					  =unit_vector_to_spherical(avgpm->major);
					destroy_MWstack(spm);
				}
				peakcm=stack->coherence[idamax(
					stack->nt,
					stack->coherence,1)];
				copy_arrival_array(arrival_new,&arrivals);
				freearr(arrival_new,free);
				arrival_new = NULL;
				destroy_MWstack(stack);
				if(stack_alignment==PMESTIMATE)
						--loopback;
			}while(loopback>0);
			if(band_exit)
			{
				band_exit = 0;
				continue;
			}

			/* This routine computes the covariance of
			the estimated slowness vector */
			if(compute_slowness_covariance(stations,static_result,
				ucovariance) )
				elog_complain(0,"Problems computing slowness vector covariance estimate for evid %d and band %d\n",
					evid, i);
			/* routines below save a time window.  We compute
			the lag corrected start time at the reference station
			here as t0 to simplify this in functions that
			need this.*/
			t0 = timeref + sts0;
			/* This series of functions save results in a set
			of css3.0 extension tables.  */

			/* ampndgf+1 here is a cheap solution to the
			number of stations used in a solution.  This 
			confusion is necessary because autoediting reduces
			the data set.  Poor planning caused me to not
			force this to be saved explicitly, but ampndgf is
			an exact surrogate.  The +1 is needed because the
			calculation uses number_used - 1 since the average
			amplitude is extracted as a free parameter.
			*/
			if(MWdb_save_slowness_vector(phase,&u,t0,twin,
				array_name,evid,bankid,fc,fwin,
				ucovariance,ampndgf+1,3,
				coherence_type,peakcm,dbv))
					dbsave_error("mwslow",evid,i);
			if(MWdb_save_avgamp(array_name, evid, bankid, phase,
				fc, t0, twin, avgamp,amperr,ampndgf,
				dbv) )
					dbsave_error("mwavgamp",evid,i);
			if(MWdb_save_statics(evid, bankid, phase, fc, t0,
				twin,refelev,*gathers,moveout,static_result,
				stations,sn_ratios[i],
				arrivals, model_times,dbv))
					dbsave_error("mwtstatic:mwastatic:mwsnr",evid,i);
			t0=timeref+ts0;
			twin = te0-ts0;
			if(MWdb_save_pm(array_name,evid,bankid,phase,fc,t0,
				twin,*gathers,moveout,pm_arr,pmerr_arr,
				avgpm,avgerr,dbv)  )
					dbsave_error("mwpm",evid,i);
			/* We have to release the memory held in these
			associative arrays.  In the earlier loop the 
			function that creates them always clears them
			before continuing when they are not null.  
			The explicit NULL set after the free is done
			to make sure in looping back the particle
			motion routine clears these correctly.  */
			freearr(pm_arr,free);
			pm_arr = NULL;
			freearr(pmerr_arr,free);
			pmerr_arr = NULL;
			/* same for static arr */
			freearr(static_result,free);
			static_result = NULL;
		}
		/*release main work spaces with this series of complicated free routines.
		Here is where you really wish C had garbage collection */
		free_sn_ratios_arr(sn_ratios,nbands);
		free_MWtransform_arr(mwsig_arr,nbands,nwavelets);
		free_MWtransform_arr(mwnoise_arr,nbands,nwavelets);
		trdestroy(&tr);
		freearr(arrival0,free);
		freearr(arrivals,free);
		/* This may not be necessary, but better safe than sorry */
		arrivals = NULL;   arrival0 = NULL;   arrival_new = NULL;
	}
	free(moveout);
	free(swin);
	free(nwin);
	free(refsta);
}
Exemplo n.º 21
0
Arquivo: symg.c Projeto: nhatcher/lie
poly* MN_char(entry* lambda, lie_Index l)
{ lie_Index n=check_part(lambda,l);
  if (n==0) return poly_one(0); /* the character of $\Sym0$ */
  while (lambda[l-1]==0) --l; /* minimise |l| */
  wt_init(n); /* get ready for accumulating contributions to the character */
  { 
    entry* mu=mkintarray(3*n),* save=mu+n,* lambda_prime=save+n;
    int i, j, r, d=lambda[0]+l, k=0; /* sum of leg lengths */
    boolean* edge=alloc_array(boolean,2*d-2),* candidate=edge+d-2;
      /* lie_Index |2<=r<d| */
    enum {hor, vert}; /* values used for |edge| */
    
    for (i=0; i<n; ++i) mu[i]=0;
    
    { int r=l-1,c=0; /* current column number */
      for (j=0; r>=0; --r)
      { while (c<lambda[r]) { edge[j++]=hor; ++c; } /* columns of length |r| */
        edge[j++]=vert; /* row |r|, of length |c==lambda[r]| */
      }
    }
    
    for (r=2; r<d; ++r)
    { for (j=0; j+r<d; ++j)
        if (edge[j]==hor && edge[j+r]==vert) break;
      candidate[r]= j+r<d;
    }
    

    
    { i=0; /* index of last entry that was set in~|mu| */
      for (r=d-1; r>1; --r) /* try hooks of size |r| */
        if (candidate[r])
        { recurse: /* recursive starting point */
          
          { for (j=1; j<r; ++j) k+=edge[j]; /* leg length of hook first tried */
            for (j=0; j<d-r; ++j)
            { if (edge[j]==hor && edge[j+r]==vert)
              { edge[j]=vert; edge[j+r]=hor; mu[i]=r; save[i++]=j; goto recurse;
              resume: j=save[--i]; r=mu[i]; mu[i]=0; edge[j]=hor; edge[j+r]=vert;
              }
              k+= edge[j+r]-edge[j+1]; /* adjust |k| for hook tried next */
            }
            while (++j<d) k-= edge[j]; /* restore |k| */
          }
        }
    }
    
    { int r=l,c=0,s=0; /* size of |lambda_prime| */
      for (j=0; r>0; )
        if (edge[j++]==vert) s+=lambda_prime[--r]=c;  else ++c;
        /* build |lambda_prime| from edges */
      for (j=0; j<s; ++j) mu[i++]=1; /* extend |mu| with |s| ones */
      wt_ins(mu,n_tableaux(lambda_prime,l),k%2);
      for (j=0; j<s; ++j) mu[--i]=0; /* remove the ones again */
    }
    if (i>0) goto resume;
    
     
    { freearr(edge); freearr(mu); }
  }
  return wt_collect();
}
Exemplo n.º 22
0
void ttlvz_destroy()
{
	freearr(ttlvz_models,free_Vmodel);
}
Exemplo n.º 23
0
void save_assoc(Dbptr dbi, long is, long ie, long orid, char *vmodel,
	Tbl *residual,Hypocenter h, Dbptr dbo)
{
	/* These fields are copied from input assoc table */
	long arid;
	char sta[8];
	char phase[10];
	double belief;
	/* These fields are set here */
	double delta;
	double seaz;
	double esaz;
	double timeres;
	double azres;
	double slores;
	double lddate;
	double wgt;
	char timedef[2],slodef[2], azdef[2];
	
	/* intentionally ignored:  emares, commid */


	/* passed through arg list;  orid*/

	/* We use this to produce a keyed arr list of the residual 
	list passed into here as a Tbl */

	Arr *residual_array;
	long i;
	char key[40]; 

	double r, w, reswt,uxresid, uyresid;
	double stalat, stalon; 
	double ux, uy, azimuth;
	double u,phi;  /* polar form of measured slowness vector */
	double duphi;

	dbo = dblookup(dbo,0,"assoc",0,0);
	lddate = std_now();

	/* We build an associate array for the residual tbl keying
	each entry with a sta/phase/type key  where type is 
	set in ggnloc as time, ux, or uy.  This complication is
	needed to sort out array residuals. */
	residual_array = newarr(0);
	for(i=0;i<maxtbl(residual);++i)
	{
		char *s;
		char keysta[10], keyphase[10], keytype[5];
		s = (char *)gettbl(residual,i);
		sscanf(s,"%s %s %s",keysta,keyphase,keytype);
		/* handle S-P case by having the same residual mapped
		to each half of - phase pair */
		if(strchr(keyphase,'-'))
		{
			char *phase1,*phase2;
			/* algorithm to split phase names cloned from dbgenloc */
			phase1 = strdup(keyphase);
			phase2= strchr(phase1,'-');
			*phase2 = '\0';
			++phase2;
			sprintf(key,"%s %s %s",keysta,phase1,keytype);
			setarr(residual_array,key,s);
                        sprintf(key,"%s %s %s",keysta,phase2,keytype);
                        setarr(residual_array,key,s);
			free(phase1);
		}
		else
		{
			/* normal phases are one to one */
			sprintf(key,"%s %s %s",keysta,keyphase,keytype);
			setarr(residual_array,key,s);
		}
	}
		

	for(dbi.record=is;dbi.record < ie;++dbi.record)
	{
		char *time_residual_record;
		char *ux_residual_record,*uy_residual_record;
		if( dbgetv(dbi,0,
      	    		"assoc.arid",&arid,
          		"assoc.sta",sta,
          		"assoc.phase",phase,
          		"assoc.belief",&belief,
				NULL) == dbINVALID)
		{
		  elog_die(1,"save_assoc: dbgetv error reading assoc fields of input view at record %ld\n",
				dbi.record);
		}
		if( dbgetv(dbi,0,
			"site.lat",&stalat,
			"site.lon",&stalon,
				NULL) == dbINVALID)
		{
		  elog_die(1,"save_assoc: dbgetv error reading site fields of input view at record %ld\n",
				dbi.record);
		}
		/* Find the time residual record for this arrival */
		sprintf(key,"%s %s time",sta,phase);
		time_residual_record = (char *)getarr(residual_array,key);
		if(time_residual_record == NULL)
		{
			elog_complain(1,"save_assoc:  getarr mismatch for key %s\nCannot set residual\n",key);
			timeres = TIMENULL;
			wgt = 0.0;
			strcpy(timedef,"n");
		}
		else
		{
                        /* Changed by JN to avoid gcc warning */
			/* sscanf(time_residual_record,"%*s%*s%*s%*lg%lg%lg%lg", */
			sscanf(time_residual_record,"%*s%*s%*s%*g%lg%lg%lg",
				&r,&w,&reswt);
			timeres = r;
			wgt = w*reswt;
			strcpy(timedef,"d");
		}

		sprintf(key,"%s %s ux",sta,phase);		
		ux_residual_record = (char *)getarr(residual_array,key);
		sprintf(key,"%s %s uy",sta,phase);
		uy_residual_record = (char *)getarr(residual_array,key);
                /* Corrected by JN
		if( (ux_residual_record == NULL) 
			|| (ux_residual_record == NULL))
                */
		if( (ux_residual_record == NULL) 
			|| (uy_residual_record == NULL))
		{
			/* This trick is not documented.  By setting 
			the record filed to dbNULL, and then calling dbgetv
			each of the fields will be set to their NULL value */
			dbo.record = dbNULL;
			dbgetv(dbo,0,"azres",&azres,"slores",&slores,NULL );
			strcpy(azdef,"n");
			strcpy(slodef,"n");
		}
		else
		{
		/* This gets nasty because we have to convert to polar 
		coordinates from ux, uy components */
			sscanf(ux_residual_record,"%*s%*s%*s%*g%lg",&uxresid);

			sscanf(uy_residual_record,"%*s%*s%*s%*g%lg",&uyresid);
		/* We fetch the measured slowness vector to convert */
			if( dbgetv(dbi,0,
				"arrival.slow",&u,
				"arrival.azimuth",&phi,
					NULL) == dbINVALID)
			{
		  	  elog_die(1,"save_assoc: dbgetv error reading arrival fields of input view at record %ld\n",
				dbi.record);
			}
			/* css stores slowness in s/deg, but we use
			s/km internally here so we have to convert */

			slores = sqrt(uxresid*uxresid+uyresid*uyresid);
			slores *= KMPERDEG;

			/* this is the azimuth term */
			u /= KMPERDEG;
			duphi = ux*cos(rad(azimuth)) - uy*sin(rad(azimuth));
			duphi /= u;
			azres = deg(duphi);
			strcpy(azdef,"d");
			strcpy(slodef,"d");

		}
		dist(rad(h.lat),rad(h.lon),rad(stalat),rad(stalon),
				&delta,&esaz);
		dist(rad(stalat),rad(stalon),rad(h.lat),rad(h.lon),
				&delta,&seaz);
		delta = deg(delta);
		seaz = deg(seaz);
		esaz = deg(esaz);
			
		if(dbaddv(dbo,0,
                        "arid",arid,
                        "orid",orid,
                        "sta",sta,
                        "phase",phase,
                        "belief",belief,
                        "delta",delta,
                        "seaz",seaz,
                        "esaz",esaz,
                        "timeres",timeres,
                        "timedef",timedef,
                        "azres",azres,
                        "azdef",azdef,
                        "slores",slores,
                        "slodef",slodef,
                        "wgt",wgt,
                        "vmodel",vmodel,
                        "lddate",lddate,
			NULL ) == dbINVALID)
		{
			elog_die(1,"save_assoc: dbaddv error writing assoc record for arid %ld\n",
				arid);
		}
	}
	freearr(residual_array,0);
}
Exemplo n.º 24
0
/*This is an important function that sets the set of base station corrections
used as the bias term in pmel.  These base station corrections are computed
as the difference between travel times computed by a 3D calculator 
(This program actually has no concept of this directly.  It just uses
the 3D model as a reference.) and a reference model (presumably generally
a 1D model like iasp91, but it could itself be 3D really).  Note
that if the 3D model has any station corrections set they will be applied.
For the reference model (1D) the station corrections are set by this 
function.  This allows testing or application with a global set of station
corrections used as the 3D equivalent, but allowing the results to be
space variable when used with dbpmel.  i.e. you can, if desired, use
the same travel time calculator for the 1D and 3D case, but if 
station corrections are defined for the 3D handle they will be used 
as a global bias term.  Similarly, if this same process is done with
no station corrections one can produce a "unbiased estimate" meaning
the bias term is always forced to 0 everywhere.  Experience has shown
that although this might be conceptually appealing it generally is a
bad idea unless the reference model is very good to start with.

Arguments:
	pha - associative array of phase handles for 1D reference model
		calculator (station correction of these handles are set here).
	pha3D - same as pha, but for the 3D (bias) model calculator
	sa - associative array of Station objects with station location
		information (keyed by sta name).
	hc - hypocentroid location.

Returns:
	0 - normal, aok
	> 0 - count of failures in computing travel times 
	< 0 - total failure
*/
int initialize_station_corrections(Arr *pha,Arr *pha3D, Arr *sa,Hypocenter *hc)
{
	int i,j;
	Phase_handle *p,*p3D;
	Tbl *keys;
	char *phase;
	Station *s;
	Tbl *stakeys;
	char *sta;
	int nsc_fail=0;
	Ray_Endpoints x;
	Travel_Time_Function_Output t,t3D;
	double *sc,*sc3D;

	keys = keysarr(pha);
	stakeys = keysarr(sa);
	x.slat = hc->lat;
	x.slon = hc->lon;
	x.sz = hc->z;

	for(i=0;i<maxtbl(keys);++i)
	{
		phase = gettbl(keys,i);
		p = (Phase_handle *)getarr(pha,phase);
		p3D = (Phase_handle *)getarr(pha3D,phase);
		if(pha3D == NULL)
		{
			elog_notify(0,"No handle for 3d (bias correction) for phase %s\nBias contribution set to 0 for this phase\n",
				phase);
			nsc_fail += cntarr(sa);
			/* Emptying the arr is a simple way to create
			the equivalent of all 0s*/
			if(cntarr(p->time_station_corrections)>0)
			{
				freearr(p->time_station_corrections,free);
				p->time_station_corrections=newarr(0);
			}
			continue;
		}
		for(j=0;j<maxtbl(stakeys);++j)
		{
			sta = gettbl(stakeys,j);
			s = (Station *)getarr(sa,sta);
			x.sta = s->name;
			x.rlat = s->lat;
			x.rlon = s->lon;
			x.rz = -(s->elev);
			/* Get a pointer to hold the new station correction.
			If it doesn't exist yet, create it and enter it into
			the associative array.  Note because these are direct
			pointers we don't have set the entry in the arr below*/
			sc = (double *)getarr(p->time_station_corrections,sta);
			if(sc == NULL)
			{
				allot(double *,sc,1);
				setarr(p->time_station_corrections,sta,sc);
			}
			t3D = p3D->ttcalc(x,phase,RESIDUALS_ONLY);
			t = p->ttcalc(x,phase,RESIDUALS_ONLY);
			if( (t.time == TIME_INVALID) 
				|| (t3D.time == TIME_INVALID) )
			{
				elog_notify(0,"Travel time failure for phase %s computing reference corrections for station %s\nCorrection set to 0.0\n",
					phase,sta);	
				*sc = 0.0;
				++nsc_fail;
			}
			else
			{
				*sc = t3D.time - t.time;
				sc3D = (double *)
				    getarr(p3D->time_station_corrections,sta);
				if(sc3D != NULL)
					*sc += *sc3D;
			}
		}
	}
Exemplo n.º 25
0
/* This function computes theoretical arrival times and a slowness vector
(at the reference station for an array) based on a model and method
defined in a parameter file and using the generic travel time interface
of datascope/antelope.  

Arguments:
///inputs////
	stations - Associative array of MWstation objects used in 
			multiwavelet programs
	refsta - name of reference station to use.  The slowness 
		vector is computed based on a source location accessed
		through the db pointer (see below) and the location of
		the reference station.  If the refsta is not found in 
		the stations array the first element of the sorted list
		of stations will be used in an attempt to recover.  For
		most arrays this would be a minor error.
	phase - name of seismic phase to compute theoretical times and
		slowness vector for.  
	db - This db pointer MUST point to a single row of a db view with 
		the origin table joined as part of the view.   The hypocenter
		information is read with dbgetv passing this db pointer 
		directly.
	pf - parameter space pointer.  We search for model and method
		fields from pf to get the interface right. 
///outputs///
	times - associative array keyed by station name of theoretical
		arrival times (stored as double * s).  If there are 
		problems computing any travel times they will be absent
		from this array.  When this array is used, be aware you
		can't assume all the times are filled.
	slow - theoretical slowness vector.  If the slowness vector
		calculation fails this is set to 0 and the refsta field
		is set to "BAD".  This allows the use of the slowness 
		vector without errors in a less than ideal way.  The 
		BAD condition should be trapped.

Return codes:
	0 = normal return, no problems
	> 0 = count of travel time failures
	< 0 = nothing was computed.  Both slowness and times should be
		assumed invalid.

Author:  Gary Pavlis
Written: December 2000
*/

static Hook *hook=0;  /*Used by ttcalc */
int MWget_model_tt_slow(Arr *stations,
			char *refsta,
			char *phase,
			Dbptr db,
			Pf *pf,
			Arr **times,
			MWSlowness_vector *slow)
{
	Tbl *t;  /* used to hold keys with keysarr */
	char *key;  /* key returned from Tbl *t */
	int i;
	MWstation *s, *s0; 
	char *model;
	char *method;
	TTGeometry geometry;
	TTTime *atime;
	TTSlow *u0,*u;
	Tbl *treturn=NULL,*ureturn=NULL;
	int error_count=0;
	double *twork;

	s0 = (MWstation *)getarr(stations,refsta);
	if(s0 == NULL) elog_complain(0,"MWget_model_tt_slow:  cannot find reference station %s\nWill arbitarily pick first station found as refererence for computing model based time and slowness\n",refsta);
	if(dbgetv(db,0,"origin.lat",&(geometry.source.lat),
		"origin.lon",&(geometry.source.lon),
		"origin.depth",&(geometry.source.z),
		"origin.time",&(geometry.source.time),0) == dbINVALID)
	{
		elog_complain(0,"MWget_model_tt_slow:  dbgetv error reading origin data\nCannot compute theoretical arrival times and slowness\n");
		return(-1);	
	}
	model = pfget_string(pf,"TTmodel");
	method = pfget_string(pf,"TTmethod");
	if( (model == NULL) || (method == NULL) )
	{
		elog_complain(0,"MWget_model_tt_slow:  TTmodel or TTmethod missing from parameter file\nCannot compute theoretical travel times and slowness vector\n");
		return(-1);
	}
	t = keysarr(stations);
	if(maxtbl(t)<=0)
	{
		elog_complain(0,"MWget_model_tt_slow:  no data to process\n");
		return(-1);
	}
	/* recover from reference station error */
	if(s0==NULL)
	{
		key = gettbl(t,0);
		
		elog_log(0,"Setting reference station to %s for travel time computation\n",
			key);
	}
	/* We now compute the slowness vector estimated for the reference
	station location at 0 elevation. */
	strcpy(geometry.receiver.name,s0->sta);
	geometry.receiver.lat = s0->lat;
	geometry.receiver.lon = s0->lon;
	geometry.receiver.z = 0.0;
	if(slow->refsta == NULL) slow->refsta = strdup(refsta);
	if(ucalc(method,model,phase,0,&geometry,&ureturn,&hook))
	{
		elog_complain(0,"MWget_model_tt_slow:  slowness vector calculation failed for reference station %s\nSetting model slowness vector to zero and attempting to continue.\n",
			s0->sta);
		slow->ux = 0.0;
		slow->uy = 0.0;
	}
	else
	{
		u0 = (TTSlow *)gettbl(ureturn,0);
		slow->ux = u0->ux;
		slow->uy = u0->uy;
	}
	/* If the output times array is not empty we have to free it up 
	and start fresh.  Otherwise we will have a memory leak or access
	old values stored there.  This probably should be handled 
	externally, but better to be redundant.*/
	if(*times != NULL) freearr(*times,free);
	*times = newarr(0);

	/* Look through the station list */
	for(i=0;i<maxtbl(t);i++)
	{
		double estatic;
		key = gettbl(t,i);
		s = (MWstation *)getarr(stations,key);
		strcpy(geometry.receiver.name,s->sta);
		geometry.receiver.lat = s->lat;
		geometry.receiver.lon = s->lon;
		geometry.receiver.z = 0.0;
		if(ttcalc(method,model,phase,0,&geometry,&treturn,&hook))
		{
			elog_complain(0,"MWget_model_tt_slow: Travel time computation failed computing travel time for station %s\nCannot compute residuals\n",
				s->sta);
			++error_count;
		}
		else
		{
			atime = (TTTime *)gettbl(treturn,0);
			estatic = compute_elevation_static(s,*slow,0.0,phase);
			allot(double *,twork,1);
			*twork = geometry.source.time
				+ (atime->value) + estatic;
			setarr(*times,key,twork);
		}
	}
	freetbl(ureturn,0);
	freetbl(treturn,0);
	return(error_count);
}
Exemplo n.º 26
0
Arquivo: grpdata.c Projeto: d4g33z/lie
matrix* simp_proots(simpgrp* g)
{ if (g->roots!=NULL) return g->roots;
  { _index r=g->lierank,l,i,last_root;
    entry** cartan=simp_Cartan(g)->elm;
    entry** posr=(g->roots=mkmatrix(simp_numproots(g),r))->elm;
    entry* level=(g->level=mkvector(simp_exponents(g)[r-1]+1))->compon;
    entry* norm=(g->root_norm=mkvector(g->roots->nrows))->compon;
    entry* alpha_wt=mkintarray(r);
      /* space to convert roots to weight coordinates */
    setlonglife(g->roots),
    setlonglife(g->level),
    setlonglife(g->root_norm); /* permanent data */
    
    { _index i,j;  for (i=0; i<r; ++i)  for (j=0; j<r; ++j) posr[i][j] = i==j;
      level[0]=0; last_root=r;
      for (i=0; i<r; ++i) norm[i]=1; /* norms are mostly |1| */
      switch (g->lietype) /* here are the exceptions */
      {	    case 'B': 
        for (i=0; i<r-1; ++i) norm[i]=2; /* $2,2,\ldots,2,1$ */
       break; case 'C': norm[r-1]=2; /* $1,1,\ldots,1,2$ */
       break; case 'F': norm[0]=norm[1]=2; /* $2,2,1,1$ */
       break; case 'G': norm[1]=3; /* $ 1,3$ */
      }
    }
    for (l=0; last_root>level[l]; ++l)
    { level[l+1]=last_root; /* set beginning of a new level */
      for (i=level[l]; i<level[l+1]; ++i)
	
	{ _index j,k; entry* alpha=posr[i];  mulvecmatelm(alpha,cartan,alpha_wt,r,r);
	    /* get values $\<\alpha,\alpha_j>$ */
	  for (j=0; j<r; ++j) /* try all fundamental roots */
	  { entry new_norm; 
	    
	    { if (alpha_wt[j]<0) /* then $\alpha+\alpha_j$ is a root; find its norm */
	        if (norm[j]==norm[i]) new_norm=norm[j]; /* |alpha_wt[j]==-1| */
	        else new_norm=1; /* regardless of |alpha_wt[j]| */
	      else if (norm[i]>1 || norm[j]>1) continue; /* both roots must be short now */
	      else if (strchr("ADE",g->lietype)!=NULL) continue;
	        /* but long roots must exist */
	      else if (alpha_wt[j]>0)
	        if (g->lietype!='G'||alpha_wt[j]!=1) continue;  else new_norm=3;
	        /* $[2,1]\to[3,1]$ for $G_2$ */
	      else if (alpha[j]==0) continue;
	        /* $\alpha-\alpha_j$ should not have a negative entry */
	      else
	      { 
	        { --alpha[j]; 
	          for (k=level[l-1]; k<level[l]; ++k) 
	            if (eqrow(posr[k],alpha,r)) break;
	          ++alpha[j]; 
	          if (k==level[l]) continue;
	        }
	      new_norm=2; }
	    }
	    ++alpha[j]; /* temporarily set $\alpha\K\alpha+\alpha_j$ */
	    for (k=level[l+1]; k<last_root; ++k)
	      if (eqrow(posr[k],alpha,r)) break;
	      /* if already present, don't add it */
	    if (k==last_root)
	      { norm[last_root]=new_norm; copyrow(alpha,posr[last_root++],r); }
	    --alpha[j]; /* restore |alpha| */
	  }
	}
    }
    freearr(alpha_wt); return g->roots;
  }
}
Exemplo n.º 27
0
void initpf( char *pf )

{
    double epoch, sec;
    Pf  *Param;
    Tbl *Inputs;
    Arr *pfarr;
    DIR *dirp;
    struct dirent *direntp;
    char *istr;
    char *path, exten[132], name[132], *pfile;
    int getone = 0;
    int yr, day, hr, min;
    int i, n, ninputs;


    if( (pfile = (char *) malloc(256)) == NULL)
        elog_die( 1, "initpf(): malloc error\n");

    /* Get today's time  */

    if( pf == NULL )  {
        epoch = now();
        e2h(epoch, &yr, &day, &hr, &min, &sec);

        /* Get List of Parameter Files  */

        if( (path = getenv("DASPF_PATH") ) == NULL || (int) strlen(path) <= 0 )  {
            DASPF = "pkt";

        }  else  {
            sprintf( pfile, "%04d%03d%02d%02d\0", yr, day, hr, min);
            dirp = opendir(path);
            if(dirp == NULL)
                elog_die(1, "initIP():Can't open %s directory.\n", path);
            pfarr = newarr( 0 );
            while ( (direntp = readdir(dirp)) != NULL ) {
                istr = direntp->d_name;
                fexten( istr, exten);
                if( strncmp( exten, "pf", strlen("pf")) == 0)
                    setarr( pfarr, direntp->d_name, "Y" );
            }

            /* Get the most recent PF name  */

            Inputs = keysarr( pfarr );
            ninputs = maxtbl( Inputs );
            for( i = 0; i < ninputs; i++ )  {
                istr = ( char *) gettbl( Inputs, i );
                if( strcmp( istr, pfile ) == 0 ) {
                    sprintf( pfile, "%s/%s\0", path, istr);
                    getone = 1;
                    break;
                }
                else if( strcmp( istr, pfile ) > 0 )  {
                    if( i == 0 )
                        istr = ( char *) gettbl( Inputs, (0));
                    else
                        istr = ( char *) gettbl( Inputs, (i -1));
                    strncpy( name, istr, strlen(istr));
                    name[strlen(istr)-strlen(".pf")] = '\0';
                    for(n = 0; n < (int) strlen(name); n++)
                        if(!isdigit(name[n])) break;
                    if( n == (int) strlen(name))
                        sprintf( pfile, "%s/%s\0",path, istr);
                    else
                        sprintf( pfile, "pkt.pf" );
                    getone = 1;
                    break;
                }
            }  /* end for  */
            if( !getone ) {
                istr = ( char *) gettbl( Inputs, (ninputs -1));
                sprintf( pfile, "%s/%s\0",path, istr);
            }

            /* Read configuration file  */

            pfile[strlen(pfile)-strlen(".pf")] = '\0';
            DASPF = pfile;
            freearr( pfarr, 0 );
            closedir( dirp );
        }
    }  else {

        /* Read configuration file  */

        fexten( pf, exten);
        if( strncmp( exten, "pf", strlen("pf")) == 0)
            pf[strlen(pf) - strlen(".pf")] = '\0';
        DASPF =  pf;
    }

}
Exemplo n.º 28
0
void save_assoc(Tbl *ta, Tbl *tu, 
	int orid, char *vmodel, Hypocenter hypo, 
	Dbptr db, int orb)
{
        double delta;
        double seaz;
        double esaz;
        double azres;
        double slores;
        Arr *u_arr;
	char key_arid[20];
	Tbl *udregs; 
        int i,n;
 
        double ux, uy, azimuth;
        double duphi;
	Arrival *a;
	Slowness_vector *u;

	/* We build an associative array keyed to arid for
	all the slowness vector measurements. 
	Then in the loop below we can efficiently find any
	slowness vectors associated with the same arid as
	an Arrival.  The overhead in this is significant, but
	it makes it completely general and open ended.  */
	n = maxtbl(tu);
	u_arr = newarr(0);
	for(i=0;i<n;i++)
	{
		Slowness_vector *utmp;
		utmp = (Slowness_vector *)gettbl(tu,i);
		sprintf(key_arid,"%d",utmp->arid);
		setarr(u_arr,key_arid,utmp);
	}
	db = dblookup(db,0,"assoc",0,0);
	db.record = dbSCRATCH;

	n=maxtbl(ta);
	for(i=0;i<n;i++)
	{
		a=(Arrival*)gettbl(ta,i);
		dist(rad(hypo.lat),rad(hypo.lon),
		  rad(a->sta->lat),rad(a->sta->lon),&delta,&esaz);
		dist(rad(a->sta->lat),rad(a->sta->lon),
		  rad(hypo.lat),rad(hypo.lon),&delta,&seaz);
		sprintf(key_arid,"%d",a->arid);
		u = (Slowness_vector *) getarr(u_arr,key_arid);
		if(u == NULL)
		{
		    if(dbputv(db,0,
			"orid",orid,
			"arid",a->arid,
			"sta",a->sta->name,
			"phase",a->phase->name,
			"delta",deg(delta),
			"seaz",deg(seaz),
			"esaz",deg(esaz),
			"timeres",(double)a->res.raw_residual,
			"timedef","d",
			"vmodel",vmodel,
			"wgt",(double)a->res.residual_weight,
		  	0)<0)
		    {
			  elog_complain(0,
			    "Can't add assoc record for station %s arid = %d orid = %d to working db scratch record\nRecord skipped and not saved anywhere\n",
				a->sta->name,a->arid,orid);
			  continue;
		    }
		}
		else
		{
			slores = deg2km(sqrt(sqr(u->xres.raw_residual) 
				+ sqr(u->yres.raw_residual)));
			azimuth = atan2 ( u->uy, u->ux ) ;
			duphi = (u->ux*cos(azimuth) 
				- u->uy*sin(azimuth)) 
				/ sqrt(sqr(u->ux)+ sqr(u->uy)) ;
			azres = deg(duphi);
			if(dbputv(db,"assoc",
				"orid",orid,
				"arid",a->arid,
				"sta",a->sta->name,
				"phase",a->phase->name,
				"delta",deg(delta),
				"seaz",deg(seaz),
				"esaz",deg(esaz),
				"timeres",(double)a->res.raw_residual,
				"timedef","d",
				"vmodel",vmodel,
				"slores",slores,
				"slodef","d",
				"azres",azres,
				"azdef","d",
				"wgt",(double)a->res.residual_weight,
		  	  0)<0)
			{
			  	elog_complain(0,
				  "Can't add assoc record for station %s arid = %d orid = %d to working db scratch record\nRecord skipped and not saved anywhere\n",
				a->sta->name,a->arid,orid);
				delarr(u_arr,key_arid);
				continue;
			}
			/* We delete this entry from u_arr, then we
			can scan below for the dregs easily */
			delarr(u_arr,key_arid);
		}
		if(save_dbrecord(db,orb))
			elog_complain(0,"Error saving assoc record for arid %d\n",
				a->arid);
	}
	/* Since it is possible that slowness vectors can be measured
	with no arrival time, we need to take care of that possibility.
	We do that by checking for dregs in u_arr not removed with
	delarr calls above */
	udregs = keysarr(u_arr);

	n = maxtbl(udregs);
	for(i=0;i<n;i++)
	{
		char *key;
		key = gettbl(udregs,i);
		u = (Slowness_vector *) getarr(u_arr,key);
                dist(rad(hypo.lat),rad(hypo.lon),
                  rad(u->array->lat),rad(u->array->lon),&delta,&esaz);
                dist(rad(u->array->lat),rad(u->array->lon),
                  rad(hypo.lat),rad(hypo.lon),&delta,&seaz);
                slores = deg2km(sqrt(sqr(u->xres.raw_residual)
                          + sqr(u->yres.raw_residual)));
                azimuth = atan2 ( u->uy, u->ux ) ;
                duphi = (u->ux*cos(azimuth)
                          - u->uy*sin(azimuth))
                          / sqrt(sqr(u->ux)+ sqr(u->uy)) ;
                azres = deg(duphi);
		/* The residual weight extraction from the ux component is 
		not ideal here because it could be wrong.  It is unavoidable
		due to polar-cartesian conversion */
		if(dbputv(db,"assoc",
			"orid",orid,
			"arid",u->arid,
			"sta",u->array->name,
			"phase",u->phase->name,
			"delta",deg(delta),
			"seaz",deg(seaz),
			"esaz",deg(esaz),
			"timedef","n",
			"vmodel",vmodel,
			"slores",slores,
			"slodef","d",
			"azres",azres,
			"azdef","d",
			"wgt",(double)u->xres.residual_weight,
	  	  0)<0)
		{
		  	elog_complain(0,"Can't add assoc record for array slowness vector with %s arid = %d and orid = %d to working db scratch record\nNothing saved\n",
			u->array->name,u->arid,orid);
			continue;
		}
		if(save_dbrecord(db,orb))
			elog_complain(0,"Error saving assoc record for arid %d\n",
				u->arid);		

	}
	/* We must not use regular free here, or later we could try
	to free the same area twice.  That is, u_tmp contains keyed
	version of the pointers stored in tu.  This releases only
	the Arr structures, but leaves the pointers to be freed 
	later.  I've never seen a better example of the need for
	a decent garbage collection system. */
	freetbl(udregs,free_nothing);
	freearr(u_arr,free_nothing);
}
Exemplo n.º 29
0
local simpgrp* simp_type(entry** m, entry n)
{ matrix* adjs=mkmatrix(n,3);
  entry** adj=adjs->elm /* |adj[i]| lists up to 3 neighbours of node |i| */
  ,* norm=mkintarray(3*n) /* norms of roots */
  ,* valency=&norm[n] /* valencies in Dynkin diagram */
  ,* p=&valency[n]; /* permutation of |n| */
  simpgrp* result;
  lie_Index i,j,k, a_val[4]={-1,-1,-1,-1};
    /* |a_val[i]| is index of a node of valency |i|, if any */

  if (n==0) error("empty input in simp_type\n");
  
  { for (i=0;i<n;i++) valency[i]=0;
      /* |valency[i]| is also index of next slot in |adj[i]| */
    for (i=n; --i>=0;)
    { norm[i]= Norm(m[i]); /* where |Norm(x)==Inprod(x,x)/2| */
      for (j=i; --j>=0;)
        if (Inprod(m[i],m[j])!=0) /* then valencies increase */
        { if (valency[i]>=3 || valency[j]>=3) error ("valency >3 found\n");
  	adj[i][valency[i]++]=j; adj[j][valency[j]++]=i;
  	/* update valencies and adjacencies */
        }
      a_val[valency[i]]=i; /* valency of node |i| is now known */
    }
  }
  if (a_val[3]<0)
  
  { lie_Index e; /* index of end node (|valency[e]<=1|) */
    if (a_val[0]>=0) p[0]=e=a_val[0]; /* must be type $A_1$ */
    else
    { if (a_val[1]>=0) p[0]=e=a_val[1]; /* other linear types */
      else error("no end node found\n");
  
      
      { k=p[1]=adj[e][0]; /* the unique neighbour of node |e| */
        for(i=2;i<n;i++)  p[i]=k=opposite(p[i-2],k); /* here |k==p[i-1]| */
      }
      
      if ( n==2 && norm[p[0]]+2*norm[p[1]]==5
        || n>=3 && norm[p[0]]!=norm[p[1]]
        || n==4 && norm[p[1]]<norm[p[2]]
         )
      { for (i=0; i<n-1-i; i++) swap(&p[i],&p[n-1-i]); e=p[0]; }
    }
    
    { entry norm0=norm[p[0]], norm1=norm[p[n-1]];
      if (norm0==norm1) result = mksimpgrp('A',n);
      else if (norm1==3) result=mksimpgrp('G',2);
      else if (norm1==2) result=mksimpgrp('C',n);
      else if (norm0!=2) error("I don't recognize this Cartan Type\n");
      else if (n==4 && norm[p[2]]==1) result=mksimpgrp('F',4);
      else result=mksimpgrp('B',n);
    }
  }
 /* no nodes of valency 3 */
  else 
       { entry* branch=adj[a_val[3]], end[3], end_count=0;
         for (j=2; j>=0; j--)
           if (valency[branch[j]]==1) end[end_count++]=branch[j];
         if (end_count>1) 
                         { p[n-1]=end[1]; p[n-2]=end[0]; p[n-3]=a_val[3];
                           k=p[n-4]=branch[0]+branch[1]+branch[2]-p[n-1]-p[n-2];
                             /* the remaining branch */
                           for(i=n-5; i>=0; i--)
                           { if (valency[k]!=2) error("unlinear Dn tail.\n");
                             p[i]=k=opposite(p[i+2],k);
                           }
                           result=mksimpgrp('D',n);
                         }
         else if (end_count==1) 
                              { p[3]=a_val[3]; p[1]=end[0];
                                for (j=2; j>=0; j--)
                                  if (valency[branch[j]]==2)
                                    if (valency[opposite(a_val[3],branch[j])]==1) break;
                                if (j<0) error("type E not recognised\n");
                                p[2]=branch[j]; p[0]=opposite(p[3],p[2]);
                                p[4]=k=branch[0]+branch[1]+branch[2]-p[1]-p[2]; /* remaining branch */
                                for(i=5;i<n;i++)
                                { if (valency[k]!=2) error("wrong type E system.\n");
                                  p[i]=k=opposite(p[i-2],k);
                                }
                                result=mksimpgrp('E',n);
                              }
         else error("no end node adjacent to valency 3 node\n");
       }
  
  for (i=0; i<n; i++) if (p[i]>=0) /* then |p[i]| starts an untreated cycle */
  { entry* mi=m[j=i]; /* record beginning of cycle */
    while (p[j]!=i)
      { k=j; j=p[j]; m[k]=m[j]; p[k]= -1; }
        /* assign |m[j]=m[p[j]]| and advance */
    m[j]=mi; p[j]= -1; /* close the cycle */
  }
  freemem(adjs); freearr(norm);
  return result;
}