/* This routines cautiously saves the emodel vector. It is cautious
because the emodel table is not part of the css3.0 schema. If it
cannot find info on the emodel table, it issues an error and returns.
Otherwise, it will save the emodel vector to this special table.
Author: Gary L. Pavlis
Written: June 29, 1998 */
int save_emodel(int orid, float *emodel, Dbptr db)
{
Dbptr dbemod;
dbemod = dblookup(db, 0,"emodel",0,0);
if(dbemod.table == dbINVALID)
{
elog_log(0,"emodel table not defined for output database\nAdd genloc mods\n");
return(1);
}
else
{
if(dbaddv(dbemod,0,
"orid",orid,
"emodelx",emodel[0],
"emodely",emodel[1],
"emodelz",emodel[2],
"emodelt",emodel[3],
NULL ) == dbINVALID)
{
elog_log(0,"dbaddv error for emodel table\n");
return(-1);
}
}
return(0);
}
int
open_socket ( char *name, int default_port )
{
int fd ;
struct sockaddr_in serv_addr ;
char server[256] ;
char ipc[32] ;
int port ;
memset ( (char *) &serv_addr, 0, sizeof(serv_addr) ) ;
parsename ( name, default_port, server, &port ) ;
name2ip(server, (struct in_addr *)&serv_addr.sin_addr.s_addr, ipc ) ;
serv_addr.sin_family = AF_INET ;
serv_addr.sin_port = htons ( port ) ;
if ( (fd = socket(PF_INET, SOCK_STREAM, 0 )) < 0 ) {
elog_log( 1, "Can't open stream socket\n" ) ;
fd = -1 ;
} else if ( connect(fd,
(struct sockaddr *) &serv_addr, sizeof(serv_addr)) < 0 ) {
close ( fd ) ;
fd = -1 ;
} else {
ignoreSIGPIPE() ;
}
return fd ;
}
int isGeographicallyInside(Point P, Point *polygon, long n) {
long i;
double distance,azi;
Point P_null;
Point *np=malloc(n*sizeof(Point));
int retval;
P_null.lat= 0.0;P_null.lon=0.0;
for (i=0; i<n; i++) {
dist(P.lat,P.lon,polygon[i].lat,polygon[i].lon, &distance, &azi);
if (distance >= 90.0) {
elog_log(0,"is_geopgraphically_inside: Polygon and test point must be entirely within the same hemisphere!\n");
free(np);
return 0;
}
/*
both versions are not really needed, the
simplest projection ever also works (and saves time)...
polygon[i].lat=distance * sin(azi * Pi / 180.0);
polygon[i].lon=distance * cos(azi * Pi / 180.0);
latlon(0.0,0.0,distance,azi,&(polygon[i].lat),&(polygon[i].lon));
*/
np[i].lat= polygon[i].lat - P.lat;
np[i].lon= polygon[i].lon - P.lon;
}
retval= is_inside_polygon(P_null,np,n);
free(np);
return retval;
}
/* This is a small companion function for uniform_time_table_interpolate to set return value and call register_error */
Travel_Time_Function_Output set_time_table_error(char *error)
{
Travel_Time_Function_Output o;
elog_log(0,"uniform_time_table_interpolate: %s\n",error);
o.time = TIME_INVALID;
o.dtdx = 0.0;
o.dtdy = 0.0;
o.dtdz = 0.0;
return(o);
}
Slowness_Function_Output set_slowness_table_error(char *error)
{
Slowness_Function_Output o;
elog_log(0,"uniform_slowness_table_interpolate: %s\n",error);
o.ux = SLOWNESS_INVALID;
o.uy = SLOWNESS_INVALID;
o.duxdx = 0.0;
o.duxdy = 0.0;
o.duxdz = 0.0;
o.duydx = 0.0;
o.duydy = 0.0;
o.duydz = 0.0;
return o ;
}
/* Special function used in orbgenloc for repeated task sending a db record
to the orb. It basicially implements a standard error message if this
fails.
Arguments:
db - input db pointer. It is ASSUMED that db.record is dbSCRATCH
and the relevant record has been copied onto the scratch
record before calling this function.
orb - orb descriptor to send the scratch record of db to.
Returns 0 if all worked. Returns negative of number of failures
otherwise with messages placed in error log.
Author: Gary L. Pavlis
Written: May 1997
*/
int save_dbrecord(Dbptr db, int orb)
{
char *table_name;
int ret_code=0;
if(db2orbpkt(db,orb))
{
dbquery(db,dbTABLE_NAME,table_name);
elog_log(0,"Error writing a record for table %s to orb\n",
table_name);
--ret_code;
}
return(ret_code);
}
static PyObject *
python_elog_log( PyObject *self, PyObject *args ) {
char *usage = "Usage: _stock._elog_log( msg )\n";
char *msg;
if( ! PyArg_ParseTuple( args, "s", &msg ) ) {
USAGE;
return NULL;
}
elog_log( 0, "%s", msg );
return NULL;
}
/* This function compute a projection of a vector b onto the
null space of a matrix using orthogonal matrices computed from
an svd of an original matrix using the sunperf routine
dgesvd.
Arguments:
U - matrix of singular vectors used to compute the projector.
The projector is computed as I - UU^T
Note: vectors are assumed stored in columns ala FORTRAN
m - number of rows in U
n - number of columns of U to use in forming the projector.
(the output is a copy of the input if n>= m)
b - vector to be projected (length m)
bp - vector to hold projection (length m)
Normal return is 0. Nonzero return indicates and error has been
posted with elog_log.
Author: Gary Pavlis
*/
int null_project(double *U,int m, int n, double *b, double *bp)
{
int i;
double val;
dcopy(m,b,1,bp,1);
if(n>=m)
{
elog_log(0,"null_project passed illegal U matrix of size %d by %d\nProjection request discarded\n",
m,n);
return(1);
}
for(i=0;i<n;i++)
{
val = ddot(m,(U+i*m),1,b,1);
daxpy(m,-val,(U+i*m),1,bp,1);
}
return(0);
}
int load_initial_statics(Pf *pf, Arr *a)
{
int nset;
Tbl *t;
char sta[10];
double statics;
char *line;
MWstation *s;
int i;
t = pfget_tbl(pf,"initial_statics");
if(t == NULL)
{
elog_notify(0,"initial_statics table missing from parameter file. initial statics all set to 0.0\n");
return(0);
}
for(i=0,nset=0;i<maxtbl(t);i++)
{
line = gettbl(t,i);
if((sscanf(line,"%s %lf %lf",sta,&statics)) != 2)
{
elog_notify(0,"Syntax error reading line from initial_statics Tbl\nOffending line->%s\n",
line);
continue;
}
s = (MWstation *)getarr(a,sta);
if(s == NULL)
{
elog_notify(0,"Station %s listed in initial_statics table not found in master table\n",
sta);
continue;
}
elog_log(0,"Setting initials static for %s to %lf\n",
sta,statics);
s->initial_static = statics;
++nset;
}
return(nset);
}
/* This is the function actually called to build and fill the multiwavelet station objects.
It basically calls all three functions defined above in the correct sequence. This
was an intentional modularization done to simply code maintenance by separating out some
parts linked to different input objects (i.e. pfs versus dbs).
The function returns an assembled Arr containing pointers to MWstation objects keyed
by the station name.
Arguments:
db - Database pointer to css3.0 database with a site table
pf - parameter object previously loaded
time - epoch time of start of this data set.
The "time" variable is needed due to a peculiarity of how site is keyed in css3.0.
(see the load_station_geometry function comments above for details.)
Author: G. Pavlis
Written: March 1999
*/
Arr *build_station_objects(Dbptr db, Pf *pf, double time)
{
int nsta_pf,nsta; /* nsta_pf is the number of stations defined in the
parameter file descriptions while nsta
is used for comparison from each function */
int nbands; /* number of frequency bands (needed to define weight vectors */
Arr *a;
char *refsta;
MWstation *s;
nbands = pfget_int(pf,"number_frequency_bands");
a = create_station_objects(pf,nbands);
nsta_pf = cntarr(a);
nsta = load_surface_velocity(pf, a);
if(nsta != nsta_pf)
elog_complain(0,"Surface velocity defined for only %d of %d stations\n",
nsta,nsta_pf);
nsta = load_station_geometry(db,a,time);
if(nsta<=0)
elog_die(0,"load_station_geometry failed to match any stations in parameter file with database site table\n");
if(nsta != nsta_pf)
elog_complain(0,"Missing entries in site table\nMatched only %d of %d defined in the parameter file\n",
nsta,nsta_pf);
/* This is an extra sanity check. We require refsta to be in the
site table or all hell will break loose. */
refsta = get_refsta(a);
s = (MWstation *)getarr(a,refsta);
if(s == NULL) elog_die(0,"Station site table error: reference station %s must appear in site table\n",
refsta);
free(refsta);
nsta = load_initial_statics(pf, a);
elog_log(0,"Set initial statics on %d stations\n",nsta);
return(a);
}
Location_options parse_options_pf (Pf *pf)
{
Location_options o;
char *s; /* string buffer */
int i;
int recenter=0; /* recenter flag */
o = load_default_options();
s = pfget_string(pf,"arrival_residual_weight_method");
/* Note this implicitly accepts the default if the keyword is missing */
if(s != NULL)
{
if(!strcasecmp(s,"bisquare")) o.atime_residual_weight = BISQUARE;
if(!strcasecmp(s,"thomson")) o.atime_residual_weight = THOMSON;
if(!strcasecmp(s,"huber")) o.atime_residual_weight = HUBER;
if(!strcasecmp(s,"none")) o.atime_residual_weight = NONE;
}
/* Do the same for slowness */
s = pfget_string(pf,"slowness_residual_weight_method");
if(s != NULL)
{
if(!strcasecmp(s,"bisquare")) o.slow_residual_weight = BISQUARE;
if(!strcasecmp(s,"thomson")) o.slow_residual_weight = THOMSON;
if(!strcasecmp(s,"huber")) o.slow_residual_weight = HUBER;
if(!strcasecmp(s,"none")) o.slow_residual_weight = NONE;
}
o.atime_distance_weight = pfget_boolean_wdef(pf,
"time_distance_weighting",o.atime_distance_weight);
o.slow_distance_weight = pfget_boolean_wdef(pf,
"slowness_distance_weighting",o.slow_distance_weight);
o.slowness_weight_scale_factor = (float) pfget_double_wdef(pf,
"slowness_weight_scale_factor",
o.slowness_weight_scale_factor);
o.min_error_scale = (float) pfget_double_wdef(pf,
"min_error_scale",o.min_error_scale);
o.max_error_scale = (float) pfget_double_wdef(pf,
"max_error_scale",o.max_error_scale);
for(i=0;i<4;++i) o.fix[i] = 0;
if(pfget_boolean_wdef(pf,"fix_longitude",0)) o.fix[0] = 1;
if(pfget_boolean_wdef(pf,"fix_latitude",0)) o.fix[1] = 1;
if(pfget_boolean_wdef(pf,"fix_depth",0)) o.fix[2] = 1;
if(pfget_boolean_wdef(pf,"fix_origin_time",0)) o.fix[3] = 1;
if(pfget_boolean_wdef(pf,"recenter",0)) recenter = 1;
s = pfget_string(pf,"generalized_inverse");
if(s != NULL)
{
if(!strcasecmp(s,"marquardt"))
{
o.min_relative_damp = (float) pfget_double_wdef(pf,
"min_relative_damp",o.min_relative_damp);
if(o.min_relative_damp < FLT_EPSILON)
{
elog_log(0,"Warning: minimum relative damping must be at least single precision epsilon.\nParameter file wanted %f\nReset to %f\n",
o.min_relative_damp, FLT_EPSILON);
o.min_relative_damp = FLT_EPSILON;
}
o.max_relative_damp = (float) pfget_double_wdef(pf,
"max_relative_damp",o.max_relative_damp);
o.damp_adjust_factor = (float) pfget_double_wdef(pf,
"damp_adjust_factor",o.damp_adjust_factor);
if(recenter)
o.generalized_inverse = DAMPED_RECENTERED;
else
o.generalized_inverse = DAMPED_INVERSE;
}
if(!strcasecmp(s,"pseudoinverse"))
{
o.sv_relative_cutoff = (float) pfget_double_wdef(pf,
"singular_value_cutoff",o.sv_relative_cutoff);
if(recenter)
o.generalized_inverse = PSEUDO_RECENTERED;
else
o.generalized_inverse = PSEUDOINVERSE;
}
}
o.depth_ceiling = (float) pfget_double_wdef(pf,
"depth_ceiling",o.depth_ceiling);
o.depth_floor = (float) pfget_double_wdef(pf,
"depth_floor",o.depth_floor);
o.step_length_scale_factor = (float) pfget_double_wdef(pf,
"step_length_scale_factor",o.step_length_scale_factor);
o.min_step_length_scale = (float) pfget_double_wdef(pf,
"min_step_length_scale",o.min_step_length_scale);
if(o.step_length_scale_factor >= 1.0)
{
elog_log(0,"Step length damping factors reset\nScale factors must be less than 1.0\nResetting to default of %f\n",DEFAULT_SLSF);
o.step_length_scale_factor = DEFAULT_SLSF;
if(o.min_step_length_scale >= o.step_length_scale_factor)
{
o.min_step_length_scale = (float)pow(DEFAULT_SLSF,SLSF_POW_MIN);
elog_log(0,"Min step length scale also reset to %f\n",
o.min_step_length_scale);
}
}
if(o.min_step_length_scale >= o.step_length_scale_factor)
{
o.min_step_length_scale = (float)pow(o.step_length_scale_factor,
SLSF_POW_MIN);
elog_log(0,"Min step length scale is not consistent with step length scale factor parameter\nReset to %f\n",
o.min_step_length_scale);
}
o.max_hypo_adjustments = pfget_int_wdef(pf,
"maximum_hypocenter_adjustments",o.max_hypo_adjustments);
o.dx_convergence = (float) pfget_double_wdef(pf,
"deltax_convergence_size",o.dx_convergence);
o.relative_rms_convergence = (float) pfget_double_wdef(pf,
"relative_rms_convergence_value",o.relative_rms_convergence);
return(o);
}
/* 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);
}
/* Input routine for db records for orbgenloc.
Arguments:
orb - input orb
dbtmp - temporary database used by orbpkt2db
hyp - returned data structure (see orbgenloc.h)
last_pktid - if nonzero, call orbseek to start at that location
opt - orbgenloc control structure (see orbgenloc.h)
Returns:
-1 = error, data returned is invalid
0 = aok
1 = inconsistency error. Data are certainly incomplete and should
be ignored.
IMPORTANT: this routine mallocs a single block of memory to
hold the hyp->assocs structure. This MUST be freed externally.
*/
int
orb_arrivals_in (int orb, Dbptr dbtmp, ORB_Hypocenter *hyp,
int *last_pktid, RTlocate_Options opt)
{
int pktid, nbytes, bufsize=0;
char *packet=NULL;
char srcname[64];
double time;
Dbptr db;
char *table_name;
int evid, orid, arid, prefor;
char auth[64];
int n;
int number_skipped;
if (*last_pktid > -1) orbseek (orb, *last_pktid);
/* The algorithm here is to the following sequence:
(1) hunt for a db packet that is an event record.
(2) if the event record is auth=orbassoc, start processing, otherwise
ignore it.
(3) next hunt for an origin record from orbassoc skipping any
other embedded origin records (needed in case other locators
are running)
(4) Then grab interleaved assoc->arrival rows. The algorithm
is smart and hunts for an arrival that matches the arid
of the previous assoc record skipping any other db records
that do not match.
Important assumptions of this are that only one process is emitting
assoc records into the orb. In addition, this program will block
and wait forever if an error causes a missing arrival row to never
appear that has an arid matching a previous output assoc row.
We may need a timeout or skip count parameter to avoid this
potential pitfall.
*/
/* This loop is part (1) of the algorithm */
while (1) {
if(orbreap (orb, &pktid, srcname, &time,
&packet, &nbytes, &bufsize))
{
elog_log(0,"orbreap error at packet id %d\nContinuing\n",pktid);
continue;
}
if (strncmp(srcname, "/db/", 4)) continue;
db = orbpkt2db (packet, nbytes, dbtmp);
dbquery (db, dbTABLE_NAME, &table_name);
if (strcmp(table_name, "event")) continue;
if (dbgetv (db, 0,
"auth", hyp->auth,
"evid", &(hyp->evid),
"prefor", &prefor,
0) == dbINVALID) {
elog_log(0, "orbin: dbgetv() error.\n");
return (-1);
}
if (strcmp(hyp->auth, "orbassoc")) continue;
*last_pktid = pktid;
/* This is part (2) */
while (1) {
orbreap (orb, &pktid, srcname, &time,
&packet, &nbytes, &bufsize);
if (strncmp(srcname, "/db/", 4)) continue;
db = orbpkt2db (packet, nbytes, dbtmp);
dbquery (db, dbTABLE_NAME, &table_name);
if (strcmp(table_name, "origin")) continue;
if (dbgetv (db, 0,
"auth", auth,
"evid", &evid,
"orid", &(hyp->orid),
"nass", &(hyp->nass),
"ndef", &(hyp->ndef),
"time", &(hyp->time),
"lat", &(hyp->lat),
"lon", &(hyp->lon),
"depth", &(hyp->depth),
0) == dbINVALID) {
elog_log(0, "orbin: dbgetv() error.\n");
return (-1);
}
if (strcmp(auth, "orbassoc")) continue;
if (evid != hyp->evid) continue;
if (prefor > 0 && prefor != hyp->orid) continue;
if (hyp->assocs == NULL || hyp->nass > hyp->assocs_size) {
if (hyp->assocs) free (hyp->assocs);
hyp->assocs = (Association *) malloc (hyp->nass*sizeof(Association));
if (hyp->assocs == NULL) {
elog_log(1, "orbin: malloc() error.\n");
return (-1);
}
hyp->assocs_size = hyp->nass;
}
/* This is parts (3) and (4) for assoc->arrival */
n = 0;
while (1) {
orbreap (orb, &pktid, srcname, &time,
&packet, &nbytes, &bufsize);
if (strncmp(srcname, "/db/", 4)) continue;
db = orbpkt2db (packet, nbytes, dbtmp);
dbquery (db, dbTABLE_NAME, &table_name);
if (strcmp(table_name, "assoc")) continue;
if (dbgetv (db, 0,
"orid", &orid,
"arid", &(hyp->assocs[n].arid),
"delta", &(hyp->assocs[n].delta),
"seaz", &(hyp->assocs[n].seaz),
"esaz", &(hyp->assocs[n].esaz),
"timeres", &(hyp->assocs[n].timeres),
"timedef", hyp->assocs[n].timedef,
0) == dbINVALID) {
elog_log(0, "orbin: dbgetv() error.\n");
return (-1);
}
if (orid != hyp->orid) continue;
/* This is the safe code to avoid an infinite loop */
number_skipped = 0;
while (number_skipped <= opt.db_record_skip_timeout) {
orbreap (orb, &pktid, srcname, &time,
&packet, &nbytes, &bufsize);
if (strncmp(srcname, "/db/", 4)) continue;
db = orbpkt2db (packet, nbytes, dbtmp);
dbquery (db, dbTABLE_NAME, &table_name);
if (strcmp(table_name, "arrival"))
{
++number_skipped;
continue;
}
if (dbgetv (db, 0,
"arid", &arid,
"time", &(hyp->assocs[n].time),
"sta", hyp->assocs[n].sta,
"chan", hyp->assocs[n].chan,
"iphase", hyp->assocs[n].iphase,
0) == dbINVALID) {
elog_log(0, "orbin: dbgetv() error.\n");
return (-1);
}
if (arid == hyp->assocs[n].arid) break;
}
if(number_skipped >= opt.db_record_skip_timeout)
{
elog_log(0,"Record skipping limit reached while hunting for arrival row to match assoc row.\nResynching\nOne or more events were probably skipped\n");
return(1);
}
n++;
if (n >= hyp->nass) break;
}
return (0);
}
}
}
Arr *get_freezearr(enum FREEZE_METHOD fm, Hypocenter *h0, int *evid,
Tbl **ta, int nevents)
{
int i; /* loop counter */
char *fixstr;
int minrmsevid, maxdataevid;
double rmsmin,thisrms;
int maxarrivals;
minrmsevid=evid[0];
maxdataevid=evid[0];
maxarrivals=maxtbl(ta[0]);
rmsmin=h0[0].rms_weighted;
if(rmsmin<=0.0) rmsmin=-1.0;
/* slighly inefficient to compute both of these measures all the
time, but the effort is so trivial it should not matter much.
More importantly, it allows a fallback in case the rms fields are not
set. When that is true the maxarrival method are used and a warning is
posted. */
for(i=1;i<nevents;++i)
{
int thismaxarr;
thismaxarr=maxtbl(ta[i]);
if(thismaxarr>maxarrivals)
{
maxdataevid=evid[i];
maxarrivals=thismaxarr;
}
thisrms=h0[i].rms_weighted;
if(thisrms>0.0)
{
if(rmsmin>0.0)
{
if(thisrms<rmsmin)
minrmsevid=evid[i];
}
else
{
rmsmin=thisrms;
minrmsevid=evid[i];
}
}
}
int evid_to_freeze;
switch(fm)
{
case DEPTH_MINRMS:
case ALLSPACE_MINRMS:
case ALL_MINRMS:
/* Tricky logic. if minrms is null (0 or negative),
this implicitly defaults to arrival count metric */
if(minrmsevid>0.0)
{
evid_to_freeze=minrmsevid;
break;
}
else
elog_log(0,"pmel warning: freeze mode could not use rms measure to select event to fix\nrms field was null in all hypocenters in this group\n");
case DEPTH_MAXARRIVALS:
case ALLSPACE_MAXARRIVALS:
case ALL_MAXARRIVALS:
case NOTSET:
default:
evid_to_freeze=maxdataevid;
}
switch(fm)
{
case DEPTH_MAXARRIVALS:
case DEPTH_MINRMS:
fixstr=strdup("z");
break;
break;
case ALL_MAXARRIVALS:
case ALL_MINRMS:
fixstr=strdup("xyzt");
case ALLSPACE_MAXARRIVALS:
case ALLSPACE_MINRMS:
case NOTSET:
default:
fixstr=strdup("xyz");
}
char *key=make_evid_key(evid_to_freeze);
Arr *result=newarr(0);
setarr(result,key,fixstr);
return(result);
}
/*exactly the same function for doubles */
MW_scalar_statistics MW_calc_statistics_double(double *y,int ny)
{
/* temporaries */
double mean,median, low_quartile, high_quartile;
MW_scalar_statistics stats;
int i;
/* We can't do anything if ny < 2 so return an error in this case */
if(ny < 2)
{
elog_log(0,"calculate_statistics: Insufficient data to calculate meaningful statistics\nReceived only %d data to process\n",ny);
stats.median = MAXDOUBLE;
stats.q1_4 = MAXDOUBLE;
stats.q3_4 = MAXDOUBLE;
stats.high = MAXDOUBLE;
stats.low = MAXDOUBLE;
stats.mean = MAXDOUBLE;
return(stats);
}
/* First we compute the simple mean */
for(i=0,mean=0.0;i<ny;++i) mean += y[i];
stats.mean = mean/((double)ny);
/* sort y using the qsort function */
qsort((char *)y,ny,sizeof(double),compare_double);
stats.low = y[0];
stats.high = y[ny-1];
/* These are done exactly using formulas appropriate for small samples*/
if(ny%2) /* this is case for odd number */
median = *(y + ny/2);
else
median = (y[ny/2 - 1]+y[ny/2])/2.0;
stats.median = median;
/* handle the case when ny < 4 specially to prevent seg faults */
if(ny<4)
{
stats.q1_4 = y[0];
stats.q3_4 = y[ny-1];
}
else
{
switch((ny-1)%4)
{
case(0):
low_quartile = y[(ny-1)/4];
high_quartile = y[3*(ny-1)/4];
break;
case(1):
low_quartile = (0.75*y[(ny-1)/4]+0.25*y[((ny-1)/4)+1]);
high_quartile = (0.75*y[3*(ny-1)/4]+0.25*y[(3*(ny-1)/4)+1]);
break;
case(2):
low_quartile = (0.5*y[(ny-1)/4]+0.5*y[((ny-1)/4)+1]);
high_quartile = (0.5*y[3*(ny-1)/4]+0.5*y[(3*(ny-1)/4)+1]);
break;
case(3):
low_quartile = (0.25*y[(ny-1)/4]+0.75*y[((ny-1)/4)+1]);
high_quartile = (0.25*y[3*(ny-1)/4]+0.75*y[(3*(ny-1)/4)+1]);
break;
}
stats.q1_4 = low_quartile;
stats.q3_4 = high_quartile;
}
return(stats);
}
void main(int argc, char **argv)
{
Dbptr db, dbv, dbge, dbgg;
/*ensemble_mode is primary grouping, grouping_on set if secondary on*/
int ensemble_mode,grouping_on;
Tbl *ensemble_keys;
Tbl *group_keys;
int i;
char *pfi=NULL;
Pf *pf,*pfo_head,*pfo_total;
Tbl *process_list;
int dryrun=0;
char *sift_exp=NULL;
int sift;
/*Attributes listed in require will abort program if missing
passthrough parameters will generate an error message but not
cause the program to abort. Both contain pointers to Attribute_map*/
Tbl *require,*passthrough;
Attribute_map *amap;
FILE *fp;
Tbl *error_list;
char *tag;
int sleep_time;
DB2PFS_verbose=0;
/*crack the command line*/
if(argc<3) usage();
elog_init(argc,argv);
if(dbopen(argv[1],"r",&db)==dbINVALID)
{
elog_complain(0,"dbopen failed on database %s\n",argv[1]);
usage();
}
for(i=3;i<argc;++i)
{
if(!strcmp(argv[i],"-pf"))
{
++i;
if(i>argc) usage();
pfi=argv[i];
}
else if(!strcmp(argv[i],"-V"))
usage();
else if(!strcmp(argv[i],"-v"))
DB2PFS_verbose=1;
else if(!strcmp(argv[i],"-n"))
dryrun=1;
else if(!strcmp(argv[i],"-sift"))
{
++i;
if(i>argc) usage();
sift=1;
sift_exp=argv[i];
}
else
usage();
}
if(!dryrun)
{
fp=fopen(argv[2],"r+");
if(fp==NULL) usage();
}
if(pfi==NULL) pfi=strdup("db2pfstream");
if(pfread(pfi,&pf))
elog_die(0,"Error reading parameter file %s.pf\n",pfi);
sleep_time=pfget_int(pf,"sleep_time");
/* The output view gets a virtual table name that tags the
overall collection of stuff. This comes from the parameter file
to make this program general, BUT it must be coordinated with
the reader code. */
tag = pfget_string(pf,"virtual_table_name");
if(tag==NULL)elog_die(0,"Required parameter (virtual_table_name) missing from parameter file\n");
ensemble_mode = pfget_boolean(pf,"ensemble_mode");
if(ensemble_mode)
{
ensemble_keys=pfget_tbl(pf,"ensemble_keys");
if(ensemble_keys==NULL)
elog_die(0,
"ensemble_mode is on, but no grouping keys defined\nCheck parameter file\n");
group_keys=pfget_tbl(pf,"group_keys");
if(group_keys==NULL)
grouping_on = 0;
else
{
if(maxtbl(group_keys)>0)
grouping_on = 1;
else
grouping_on = 0;
}
}
if(DB2PFS_verbose && ensemble_mode)
{
char sm[128];
char *key;
strcpy(sm,"Defining ensemble with keys: ");
for(i=0;i<maxtbl(ensemble_keys);++i)
{
key=gettbl(ensemble_keys,i);
strcat(sm,key);
}
elog_log(0,"%s\n",sm);
if(grouping_on)
{
strcpy(sm,"Grouping ensemble with keys: ");
for(i=0;i<maxtbl(group_keys);++i)
{
key = gettbl(group_keys,i);
strcat(sm,key);
}
elog_log(0,"%s\n",sm);
}
}
/*This function calls dbprocess using a tbl from pf*/
dbv=dbform_working_view(db,pf,"dbprocess_list");
if(dbv.record==dbINVALID)
elog_die(0,"dbprocess failed: check database and parameter file parameter dbprocess_list\n");
if(sift_exp!=NULL)dbv=dbsubset(dbv,sift_exp,0);
/*Now we form the groupings if needed */
if(ensemble_mode)
{
dbge = dbgroup(dbv,ensemble_keys,"ensemble",1);
if(dbge.record == dbINVALID)
elog_die(0,"dbgroup with ensemble keys failed\n");
if(grouping_on)
{
dbgg = dbgroup(dbv,group_keys,"groups",2);
if(dbgg.record == dbINVALID)
elog_die(0,"dbgroup on secondary grouping keys failed\n");
}
}
/*This builds the maps of which attributes will be saved */
require = pfget_Attribute_map(pf,"require");
if(require==NULL)
elog_die(0,"Error in parameter file for parameter require\n");
passthrough = pfget_Attribute_map(pf,"passthrough");
if(passthrough==NULL)
elog_die(0,"Error in parameter file for parameter passthrough\n");
/* Unfortunately, we have two different loops for ensemble mode
and single object mode */
if(ensemble_mode)
{
int number_ensembles;
Dbptr db_bundle_1;
Dbptr db_bundle_2;
int is_ensemble, ie_ensemble;
int isg, ieg;
int number_groups;
pfo_head=pfnew(0);
pfput_tbl(pfo_head,"ensemble_keys",ensemble_keys);
if(grouping_on) pfput_tbl(pfo_head,"group_keys",group_keys);
dbquery(dbge,dbRECORD_COUNT,&number_ensembles);
if(DB2PFS_verbose) elog_log(0,"database has %d ensembles\n",
number_ensembles);
if(grouping_on)
{
dbgg.record=0;
dbquery(dbgg,dbRECORD_COUNT,&number_groups);
if(DB2PFS_verbose)
elog_log(0,"database has %d subgroups\n",
number_groups);
}
for(dbge.record=0;dbge.record<number_ensembles;
++dbge.record)
{
Pf_ensemble *pfe;
int nmembers;
char *grp_records;
Tbl *grplist;
dbgetv(dbge,0,"bundle",&db_bundle_1,0);
dbget_range(db_bundle_1,&is_ensemble,&ie_ensemble);
nmembers = ie_ensemble-is_ensemble;
/* pfe does not need to hold the group records
for this application so the ngroups variable is
passed as 0*/
pfe=create_Pf_ensemble(nmembers,0);
/*Now loop through and load the array of pf's
with parameters defined by the attribute maps*/
for(i=0,dbv.record=is_ensemble;i<nmembers;
++i,++dbv.record)
{
pfe->pf[i]=pfnew(PFARR);
error_list=db2pf(dbv,require,pfe->pf[i]);
if(maxtbl(error_list)>0)
{
if(dryrun)
{
elog_log(0,"Ensemble %d at input database view record %d lacks required attributes\n",
dbge.record,dbv.record);
log_error_list(error_list);
}
else
{
fprintf(fp,"%s\n",END_OF_DATA_SENTINEL);
fflush(fp);
elog_log(0,"FATAL ERROR: ensemble %d at input database view record %d lacks required attributes\nOUTPUT DATA STREAM TRUNCATED\n",
i,dbv.record);
log_error_list(error_list);
exit(-1);
}
}
freetbl(error_list,free);
error_list=db2pf(dbv,passthrough,pfe->pf[i]);
if(DB2PFS_verbose)
{
elog_log(0,"Warning: null passthrough attributes for ensemble %d at row %d\n",
dbge.record,dbv.record);
log_error_list(error_list);
}
freetbl(error_list,free);
pfput_boolean(pfe->pf[i],"data_valid",1);
}
if(grouping_on)
{
grplist=newtbl(0);
do {
dbgetv(dbgg,0,"bundle",&db_bundle_2,0);
dbget_range(db_bundle_2,&isg,&ieg);
grp_records=malloc(30);
sprintf(grp_records,"%d %d",
isg-is_ensemble,ieg-is_ensemble-1);
pushtbl(grplist,grp_records);
++dbgg.record;
}
while (ieg<ie_ensemble);
pfput_tbl(pfo_head,"group_records",grplist);
}
pfo_total=build_ensemble(1,tag,pfo_head,pfe);
free_Pf_ensemble(pfe);
if(!dryrun)
{
pfout(fp,pfo_total);
fprintf(fp,"%s\n",ENDPF_SENTINEL);
fflush(fp);
}
pffree(pfo_total);
if(grouping_on)freetbl(grplist,free);
}
}
else
{
/*This is the simpler, single block mode */
int nrecords;
Pf *pfo;
dbquery(dbv,dbRECORD_COUNT,&nrecords);
pfo=pfnew(PFARR);
for(dbv.record=0;dbv.record<nrecords;++dbv.record)
{
error_list=db2pf(dbv,require,pfo);
if(maxtbl(error_list)>0)
{
if(dryrun)
{
elog_log(0,"Input database view at row %d lacks required parameters\n",
dbv.record);
log_error_list(error_list);
}
else
{
fprintf(fp,"%s\n",END_OF_DATA_SENTINEL);
fflush(fp);
elog_log(0,"FATAL: input database view at row %d lacks required parameters\n",
dbv.record);
log_error_list(error_list);
exit(-1);
}
}
freetbl(error_list,free);
error_list=db2pf(dbv,passthrough,pfo);
pfput_boolean(pfo,"data_valid",1);
if(DB2PFS_verbose)
{
elog_log(0,"Warning: null passthrough attributes for row %d of input database view\n",
dbv.record);
}
if(!dryrun)
{
pfout(fp,pfo);
fprintf(fp,"%s\n",ENDPF_SENTINEL);
}
}
}
if(!dryrun)
{
fprintf(fp,"%s\n",END_OF_DATA_SENTINEL);
fflush(fp);
sleep(sleep_time);
fclose(fp);
}
exit(0);
}
static int
autodrm_response (Dbptr db)
{
Dbptr dbstage;
static Hook *hook = 0;
char sta[MAX_STA_SIZE],
chan[MAX_CHAN_SIZE];
double time,
endtime;
long stageid;
char *s;
Response *response;
Response_group *group;
char iunits[96],
ounits[96];
char gtype[100];
long i,
j;
Paz *paz;
Fir *fir;
Fap *fap;
Fap2 *fap2;
FILE *file;
double samprate,
gnom,
gcalib;
double calper=0.0;
long decifac;
char dir[100],
dfile[100];
char filename[STRSZ];
long nmatches;
int errors = 0;
Tbl *tbl,
*stbl;
double mintime=0,
maxtime=0;
char segtype;
static Tbl *keys1 = 0,
*keys2 = 0;
if (keys1 == 0) {
keys1 = strtbl ("sta", "chan", "time", NULL);
keys2 = strtbl ("sta", "chan", "time::endtime", NULL);
}
dbstage = dblookup (db, 0, "stage", 0, 0);
nmatches = dbmatches (db, dbstage, &keys1, &keys2, &hook, &tbl);
switch (nmatches) {
case dbINVALID:
case 0:
dbgetv (db, 0, "sta", sta, "chan", chan, "time", &time, NULL);
complain (0, "Can't match record for %s:%s @ %s in stage table",
sta, chan, s = strydtime (time));
free (s);
errors++;
break;
default:
stbl = newtbl (maxtbl (tbl));
for (i = 0; i < nmatches; i++) {
dbstage.record = (long) gettbl (tbl, i);
dbgetv (dbstage, 0,
"stageid", &stageid,
"time", &time,
"endtime", &endtime,
NULL);
if (i == 0) {
mintime = time;
maxtime = endtime;
} else {
mintime = MAX (time, mintime);
maxtime = MIN (endtime, maxtime);
}
settbl (stbl, stageid - 1, (char *) i);
}
if (maxtbl (tbl) != maxtbl (stbl)) {
dbgetv (db, 0, "sta", sta, "chan", chan, "time", &time, NULL);
complain (0, "stageid numbers for %s:%s @ %s don't add up.",
sta, chan, s = strydtime (time));
free (s);
errors++;
} else {
errors += write_cal2 (db, mintime, maxtime, &calper);
for (i = 0; i < nmatches; i++) {
j = (long) gettbl (stbl, i);
dbstage.record = (long) gettbl (tbl, j);
dbgetv (dbstage, 0,
"sta", sta,
"chan", chan,
"time", &time,
"endtime", &endtime,
"stageid", &stageid,
"decifac", &decifac,
"samprate", &samprate,
"gnom", &gnom,
"gcalib", &gcalib,
"dir", dir,
"dfile", dfile,
"gtype", gtype,
"iunits", iunits,
"ounits", ounits,
NULL);
if (gcalib > 0.0) {
gnom *= gcalib;
} else if (gcalib < 0.0) {
complain (0, "gcalib = %10.3f < 0. is invalid for %s:%s @ %s.\n",
gcalib, sta, chan, s = strydtime (time));
free (s);
errors++;
}
if (*dir != '-' || *dfile != '-') {
long mark;
dbextfile (dbstage, "stage", filename);
mark = elog_mark ();
elog_log (0, "response file is '%s'", filename);
if ((file = fopen (filename, "r")) == 0
|| read_response (file, &response) < 0) {
register_error (0,
"Can't read response file %s for %s_%s @ %s",
filename, sta, chan, s = strydtime (time));
free (s);
fclose (file);
errors++;
} else {
fclose (file);
if (response->ngroups > 1) {
register_error (0,
"stage response file %s has %d stages, not 1",
filename, response->ngroups);
errors++;
} else {
group = response->groups;
switch (group->id) {
case PAZ:
/* The normalization frequency chosen in the
* response file may not necessarily be the
* same as the one chosen by calibration
* table for insertion into the seed volumes.
* Consequently, we have to adjust the
* specified gnom to be correct for the seed
* normalization frequency. Since the gain
* is
*
* G(f) = gnom_db * A_response_file * P(f) =
* gnom_seed * A_seed * P(f)
*
* We have
*
* gnom_seed = gnom_db * A_response_file /
* A_seed
*
* gnom_db is just the gnom from the stage
* table. A_response_file is the
* normalization from the response file, left
* in the stage structure. Below, we
* calculate A_seed by setting
* A_response_file to 1.0.
*
*/
paz = (Paz *) group->pvt;
for (j = 0; j < strlen (iunits); j++) {
iunits[j] = tolower (iunits[j]);
}
s = getarr (Segtype, iunits);
if (s == 0) {
segtype = 'D';
} else {
segtype = *s;
}
adwrite_paz (stageid, 0, gnom, segtype, ounits, paz);
break;
case IIR:
paz = (Paz *) group->pvt;
for (j = 0; j < strlen (iunits); j++) {
iunits[j] = tolower (iunits[j]);
}
s = getarr (Segtype, iunits);
if (s == 0) {
segtype = 'D';
} else {
segtype = *s;
}
adwrite_paz (stageid, 1, gnom, segtype, ounits, paz);
break;
case FIR:
fir = (Fir *) group->pvt;
errors += adwrite_fir (stageid, gnom, fir);
break;
case FAP:
fap = (Fap *) group->pvt;
errors += adwrite_fap (stageid, ounits, fap);
break;
case FAP2:
fap2 = (Fap2 *) group->pvt;
errors += adwrite_fap2 (stageid, ounits, fap2);
break;
default:
complain (0, "Unknown filter type %d in response file %s\n",
group->id, filename);
errors++;
break;
}
}
}
elog_flush (mark, 0);
} else {
char *desc = "";
if (gcalib > 0.0) {
gnom *= gcalib;
} else if (gcalib < 0.0) {
complain (0, "gcalib = %10.3f < 0. is an invalid value.\n", gcalib);
errors++;
}
if (strcmp (gtype, "digitizer") == 0
/* following hack for psd2db */
|| strcmp (gtype, "sensor") == 0) {
fprintf (stdout, "DIG2 %2ld %15.8e %11.5f %s\n",
stageid, gnom, samprate, desc);
} else if (strcmp (gtype, "amplifier") == 0) {
/* no corners */
fprintf (stdout, "GEN2 %2ld %c %15.8e %7.3f 0 %s\n",
stageid, *ounits, gnom, calper, desc);
} else {
complain (0, "Unrecognized gtype='%s' for %s:%s @ %s",
gtype, sta, chan, s = strydtime (time));
free (s);
errors++;
}
}
}
}
freetbl (stbl, 0);
break;
}
freetbl (tbl, 0);
return errors;
}
Robust_statistics calc_statistics(float *y,int ny)
/* calc_statistics calculate robust statistics for vector y.
i.e. median and quartiles.
Inputs:
y - input vector of length ny for which statistics are to
be calculated
Returns median, upper, and lower quartiles in Robust_statistics structure.
Algorithm calculates median, and quartiles by sorting input y array.
IMPORTANT: THIS PROCESS IS DESTRUCTIVE, AND THE Y ARRAY IS REORDERED
ON RETURN SINCE THE ROUTINE RECEIVE A POINTER TO y.
If ny < 2 returns with error signaled by setting elements of the
returned structure to MAXDOUBLE (defined in values.h from float.h). If ny = 2 or 3
the interquartiles are determined from the full range and not error is
signaled.
Author: Gary L. Pavlis, Indiana University
Written: 1994, Minor modified Feb. 1995 for location code. Original
included max and min of y, which were unnecessary here. Also
changed definition to ansi C.
*/
{
/* temporaries */
float median, low_quartile, high_quartile;
Robust_statistics stats;
/* We can't do anything if ny < 2 so return an error in this case */
if(ny < 2)
{
elog_log(0,"calculate_statistics: Insufficient data to calculate meaningful statistics\nReceived only %d data to process\n",ny);
stats.median = MAXDOUBLE;
stats.q1_4 = MAXDOUBLE;
stats.q3_4 = MAXDOUBLE;
return(stats);
}
/* sort y using the qsort function */
qsort((char *)y,ny,sizeof(float),compare_float);
/* These are done exactly using formulas appropriate for small samples*/
if(ny%2) /* this is case for odd number */
median = *(y + ny/2);
else
median = (y[ny/2 - 1]+y[ny/2])/2.0;
stats.median = (double) median;
/* handle the case when ny < 4 specially to prevent seg faults */
if(ny<4)
{
stats.q1_4 = y[0];
stats.q3_4 = y[ny-1];
}
else
{
switch((ny-1)%4)
{
case(0):
low_quartile = y[(ny-1)/4];
high_quartile = y[3*(ny-1)/4];
break;
case(1):
low_quartile = (0.75*y[(ny-1)/4]+0.25*y[((ny-1)/4)+1]);
high_quartile = (0.75*y[3*(ny-1)/4]+0.25*y[(3*(ny-1)/4)+1]);
break;
case(2):
low_quartile = (0.5*y[(ny-1)/4]+0.5*y[((ny-1)/4)+1]);
high_quartile = (0.5*y[3*(ny-1)/4]+0.5*y[(3*(ny-1)/4)+1]);
break;
case(3):
low_quartile = (0.25*y[(ny-1)/4]+0.75*y[((ny-1)/4)+1]);
high_quartile = (0.25*y[3*(ny-1)/4]+0.75*y[(3*(ny-1)/4)+1]);
break;
}
stats.q1_4 = (double) low_quartile;
stats.q3_4 = (double) high_quartile;
}
return(stats);
}
long writePolygonData(Dbptr db, Point *poly, long npoints, char *pname, int closed, int level, char *ptype, char *auth, char *dir, char *dfile, int pcode) {
/* writes poygon data into file
if dir and o dfile are NULL, use defaults
returns record number if successful,dbINVALID else
*/
long i;
char datafilename[PATH_MAX];
FILE *dfh;
int foff;
char *ftype;
int int1,int2;
float float1,float2;
double north=-360.0,east=-360.0,west=360.0,south=360.0;
double lat,lon;
int pid;
int free_dir=0;
int free_dfile=0;
char closed_flag[2];
if (closed) {
strcpy(closed_flag,"y");
} else {
strcpy(closed_flag,"n");
}
pid=dbnextid(db,"pid");
db=dblookup(db, 0, "polygon", 0, 0);
if ( (db.record=dbaddnull(db) ) ==dbINVALID) {
elog_log(0,"writePolygonData: problem adding row...");
return dbINVALID;
}
if (dir == NULL) {
dir = strdup(default_dir);
free_dir=1;
}
if (dfile == NULL) {
dfile = strdup(default_dfile);
free_dfile=0;
}
if (dbputv(db,0,"pid",pid,"dir",dir,"dfile",dfile,NULL ) == dbINVALID) {
elog_log(0,"writePolygonData: error putting dir %s & dfile %s",dir,dfile);
if (free_dir) free(dir);
if (free_dfile) free(dfile);
return dbINVALID;
}
/* some fix needed here when in "relative" directories...*/
switch (dbfilename(db,datafilename)) {
case -1:
if (makedir(dir)<0) {
elog_log(0,"writePolygonData: dir %s is NOT writable!",dir);
if (free_dir) free(dir);
if (free_dfile) free(dfile);
return dbINVALID;
}
if ((dfh= fopen(datafilename,"w"))==NULL) {
elog_log(0,"writePolygondata: error crating %s/%s",dir,dfile);
if (free_dir) free(dir);
if (free_dfile) free(dfile);
return dbINVALID;
}
foff= 0;
break;
case 0:
/*make file*/
if (makedir(dir)<0) {
elog_log(0,"problem creating directory %s",dir);
if (free_dir) free(dir);
if (free_dfile) free(dfile);
return dbINVALID;
}
if ((dfh= fopen(datafilename,"w"))==NULL) {
elog_log(0,"problem creating file %s",dir);
if (free_dir) free(dir);
if (free_dfile) free(dfile);
return dbINVALID;
}
foff= 0;
break;
case 1:
/*append*/
dfh= fopen(datafilename,"a");
fseek(dfh,0,2);
foff= ftell(dfh);
break;
case 2:
/*.Z exists....*/
elog_log(0,"writePolygonData: compression not yet supported...");
if (free_dir) free(dir);
if (free_dfile) free(dfile);
return dbINVALID;
break;
default:
elog_log(0,"writePolygondata: unknown return value from dbfilename, giving up...");
if (free_dir) free(dir);
if (free_dfile) free(dfile);
return dbINVALID;
}
ftype = polytype(pcode);
switch (pcode) {
case polyINT:
for (i=0;i < npoints;i++) {
lon=poly[i].lon;
west = (lon<west) ? lon : west;
east = (lon>east) ? lon : east;
int1=lon * 1e6;
H2N4((char *)(&int2),(char *)(&int1),1);
fwrite(&int2,sizeof(int),1,dfh);
lat=poly[i].lat;
south = (lat < south) ? lat : south;
north = (lat > north) ? lat : north;
int1=lat * 1e6;
H2N4((char *)(&int2),(char *)(&int1),1);
fwrite(&int2,sizeof(int),1,dfh);
}
fclose(dfh);
break;
case polyINTELINT:
for (i=0;i < npoints;i++) {
lon=poly[i].lon;
west = (lon<west) ? lon : west;
east = (lon>east) ? lon : east;
int1=lon * 1e6;
#ifdef WORDS_BIGENDIAN
swap4(&int1,&int2,1);
#else
int2=int1;
#endif
fwrite(&int2,sizeof(int),1,dfh);
lat=poly[i].lat;
south = (lat < south) ? lat : south;
north = (lat > north) ? lat : north;
int1=lat * 1e6;
#ifdef WORDS_BIGENDIAN
swap4(&int1,&int2,1);
#else
int2=int1;
#endif
fwrite(&int2,sizeof(int),1,dfh);
}
fclose(dfh);
break;
case polyFLOAT:
for (i=0;i < npoints;i++) {
lon=poly[i].lon;
west = (lon<west) ? lon : west;
east = (lon>east) ? lon : east;
float1=lon;
H2N4((char *)(&float2),(char *)(&float1),1);
fwrite(&float2,sizeof(float),1,dfh);
lat=poly[i].lat;
south = (lat < south) ? lat : south;
north = (lat > north) ? lat : north;
float1=lat;
H2N4((char *)(&float2),(char *)(&float1),1);
fwrite(&float2,sizeof(float),1,dfh);
}
fclose(dfh);
break;
case polyINTELFLOAT:
for (i=0;i < npoints;i++) {
lon= poly[i].lon;
west= (lon<west) ? lon : west;
east= (lon>east) ? lon : east;
float1=lon;
#ifdef WORDS_BIGENDIAN
swap4(&float1,&float2,1);
#else
float2= float1;
#endif
fwrite(&float2,sizeof(float),1,dfh);
lat= poly[i].lat;
south= (lat < south) ? lat : south;
north= (lat > north) ? lat : north;
float1=lat;
#ifdef WORDS_BIGENDIAN
swap4(&float1,&float2,1);
#else
float2= float1;
#endif
fwrite(&float2,sizeof(float),1,dfh);
}
fclose(dfh);
break;
case polyGSHHS:
elog_log(0,"writePolygonData: storage type %s not yet implemented... ",ftype);
if (free_dir) free(dir);
if (free_dfile) free(dfile);
return dbINVALID;
break;
default:
elog_log(0,"writePolygonData: unknown storage type pcode, giving up");
if (free_dir) free(dir);
if (free_dfile) free(dfile);
return dbINVALID;
}
if (dbputv(db,0,"north",north, "east",east, "south",south, "west",west,
"pname",pname,"closed",closed_flag,"level",level,"ptype",ptype, "auth",auth,"npoints",npoints, "ftype",ftype,"foff",foff,NULL ) == dbINVALID) {
elog_log(0,"writePolygonData: error putting values!");
//free (ftype);
if (free_dir) free(dir);
if (free_dfile) free(dfile);
return dbINVALID;
} else {
//free (ftype);
if (free_dir) free(dir);
if (free_dfile) free(dfile);
return db.record;
}
}
double compute_ema (Slowness_vector *u, Slowness_Function_Output *ucalc,
Dbptr db, char *vmodel)
{
Dbptr dbm, dbsv;
static Tbl *matches;
static Tbl *kmatch; /* Used to hold keys for dbmatches. */
char *key;
double velocity;
static Hook *hook=0;
long nmatches;
char cphase; /* store last char of phase name here */
int name_len;
int i;
double utotal, ema;
dbsv = dblookup(db,0,"stavel",0,0);
dbm = dblookup(db,0,"stavel",0,"dbSCRATCH");
dbputv(dbm,0,"sta",u->array->name,"phase",u->phase->name,"vmodel",vmodel,NULL );
/* It seems to be necessary to explicitly define the match keys. Using natural
keys defined with null patterns for dbmatches did not work correctly. */
kmatch = newtbl(0);
key = strdup("sta");
pushtbl(kmatch,key);
key = strdup("phase");
pushtbl(kmatch,key);
key = strdup("vmodel");
pushtbl(kmatch,key);
dbmatches(dbm,dbsv,&kmatch,&kmatch,&hook,&matches);
freetbl(kmatch,free);
nmatches = maxtbl(matches);
if(nmatches >= 1)
{
if(nmatches > 1) elog_log(0,"warning(compute_ema): multiple records found in stavel table with same primary key\n");
dbsv.record = (long) gettbl(matches,0);
dbgetv(dbsv,0,"velocity",&velocity,NULL );
}
else
{
/* No matches are found when we end up here. Revert to default and
decide to us P or S velocity by hunting backward from the string
looking for the first occurence of P or S*/
if(!strcmp(u->phase->name,"Lg"))
velocity = DEFAULT_VS;
else
{
name_len = strlen(u->phase->name);
velocity = DEFAULT_VS; /* This is the default default */
for(i=name_len-1;i>=0;i--)
{
cphase = u->phase->name[i];
if(cphase == 'S'){
velocity = DEFAULT_VS;
break;
}
else if(cphase == 'P'){
velocity = DEFAULT_VP;
break;
}
}
elog_log(0,"compute_ema: no matching entry found in stavel table for station/phase/vmodel = %s/%s/%s\n"
"Reverting to default surface velocity of %f\n",
u->array->name,u->phase->name,vmodel,velocity);
}
freetbl(matches,0);
}
/* now the actual computation is pretty trivial */
utotal = hypot(ucalc->ux,ucalc->uy);
ema = asin(utotal*velocity);
return(deg(ema));
}
long readPolygon(Dbptr db, Point **Poly) {
char fname[PATH_MAX];
char ftype[6];
long npoints;
long foff;
int pcode;
FILE *df;
Data dp; /* union of pointers, a pointer */
long i;
/*dbquery(db,dbRECORD_COUNT,&nrec);
if (nrec != 1) {
elog_log(0,"readPolygon: more than one row given...");
return -1;
}
*/
if (dbextfile(db,0,fname) <1) {
elog_log(0,"readPolygon: problem finding data in %s (are dir and dfile set properly?)",fname);
return -1;
}
if (is_file(fname) !=1) {
elog_log(0,"readPolygon: file %s not found!",fname);
return -1;
}
dbgetv(db,0,"ftype",&ftype,"npoints",&npoints,"foff",&foff,NULL );
if ((pcode = polycode(ftype)) == -1) {
elog_log(0,"readPolygon: unknown storage format %s",ftype);
return -1;
}
*Poly = malloc((npoints+2) * sizeof(Point));
dp.c=malloc(8 * 2 * (npoints +2 ));
df=fopen(fname,"r");
fseek(df,foff,0);
switch (pcode) {
case polyGSHHS:
break;
case polyINT:
/*
fread( rawdata,1,2 * sizeof(int) * npoints,df);
N2H4(rawdata,dp.i,2 * npoints);
*/
fread(dp.i, sizeof(int), npoints*2, df);
N2H4((char *) dp.i, (char *) dp.i, 2*npoints);
for (i=0; i< npoints; i++) {
(*Poly)[i].lon= dp.i[i*2] / 1.0e6;
(*Poly)[i].lat= dp.i[i*2+1] / 1.0e6;
}
break;
case polyINTELINT:
fread( dp.i, sizeof(int), 2*npoints, df);
#ifdef WORDS_BIGENDIAN
swap4(dp.i,dp.i,2 * npoints);
#endif
for (i=0; i< npoints; i++) {
(*Poly)[i].lon= dp.i[i*2] / 1.0e6;
(*Poly)[i].lat= dp.i[i*2+1] / 1.0e6;
}
break;
case polyFLOAT:
fread( dp.f, sizeof(float), 2*npoints, df);
N2H4((char *)dp.f,(char *)dp.f,2 * npoints);
for (i=0; i <npoints; i++) {
(*Poly)[i].lon= dp.f[i*2];
(*Poly)[i].lat= dp.f[i*2+1];
}
break;
case polyINTELFLOAT:
fread( dp.f, sizeof(float), 2*npoints, df);
#ifdef WORDS_BIGENDIAN
swap4((char *)dp.f,(char *)dp.f,2 * npoints);
#endif
for (i=0; i <npoints; i++) {
(*Poly)[i].lon= dp.f[i*2];
(*Poly)[i].lat= dp.f[i*2+1];
}
break;
default:
elog_log(0,"readPolygon: no code for storage format %s",ftype);
free(dp.c);
fclose(df);
return -1;
}
free(dp.c);
fclose(df);
return npoints;
}
static int
is_dbprogram( char *what, char *dbprogram, char *dbpath )
{
static Pf *pflib = 0;
static Morphtbl *morphmap = 0;
Tbl *morphlist;
int rc;
char result[STRSZ];
Tbl *parts;
rc = pfupdate( "libpforbstat", &pflib );
if( rc < 0 || pflib == NULL ) {
elog_log( 0, "pforbstat: failed to load libpforbstat.pf "
"during database analysis\n" );
return 0;
} else if( rc == 0 && morphmap == NULL ) {
elog_log( 0, "pforbstat: no morphmap present for database analysis\n" );
return 0;
}
if( rc > 0 ) {
if( morphmap != (Morphtbl *) NULL ) {
freemorphtbl( morphmap );
morphmap = 0;
}
morphlist = pfget_tbl( pflib, "dbprograms_morph" );
if( morphlist == NULL ) {
elog_log( 0, "pforbstat: failed to get dbprograms_morph "
"from libpforbstat.pf during database analysis\n" );
return 0;
}
rc = newmorphtbl( morphlist, &morphmap );
freetbl( morphlist, 0 );
if( rc != 0 ) {
elog_log( 0, "pforbstat: %d errors translating dbprograms_morph "
"from libpforbstat.pf during database analysis\n", rc );
return 0;
}
}
rc = morphtbl( what, morphmap, 0, result );
if( rc <= 0 ) {
strcpy( dbprogram, "" );
strcpy( dbpath, "" );
return 0;
} else {
parts = split( result, ' ' );
strcpy( dbprogram, gettbl( parts, 0 ) );
strcpy( dbpath, gettbl( parts, 1 ) );
freetbl( parts, 0 );
return 1;
}
}
/* Init function for uniform table.
phase = phase name to tag this table with
pf = input parameter file object to be parsed.
The following keys are required to be found in pf:
int:
nx, nz
scalar double:
dx, dz
&Tbl:
uniform_grid_time_slowness_table
The later contains the actual tables. They are ascii tables make up
of nx*nz lines (x varies most rapidly) of the following format:
time, slowness, slowness derivative wrt distance, branch
The "branch" variable is a character key defined in location.h
Optional parameters with defaults:
scalar double:
x0, y0 coordinates of first point in table (default = (0,0))
strings:
Notice that this routine requires mixed units. dx, dz, x0, and y0
must all be specified in degrees. Everything else has units derived
from km and s. That is, time is is in seconds, slowness (p) is
assumed to be in s/km, and dpdx (slowness derivative) is (s/km)/km.
This was done because the input tables are ascii, and these numbers
are scaled to units that make sense to most of us. This format is
connected to a related program called taup_convert that writes
ttables in this format using the tau-p library.
Returns 0 if no problems are encountered. REturns 1 if a serious
error occurred that rendered setup impossible for this phase.
In the later case, register_error is always called and should be
handled by calling program.
There are some fatal errors that lead to die being called here from
things like malloc failures.
*/
int uniform_table_interpolate_init(char *phase, Pf *pf)
{
XZ_table_uniform *ttable, *utable;
Tbl *t; /* pfget_tbl return to hold strings of prototables stored
in the pf structure. */
int i,j,k;
GenlocVerbose = verbose_exists() ;
if(time_tables_uniform==NULL) time_tables_uniform = newarr(0);
if(slow_tables_uniform==NULL) slow_tables_uniform = newarr(0);
ttable = (XZ_table_uniform *)malloc(sizeof(XZ_table_uniform));
utable = (XZ_table_uniform *)malloc(sizeof(XZ_table_uniform));
if( (ttable == NULL) || (utable == NULL) )
elog_die(1,"Can't alloc memory in uniform_table_interpolate_init\n");
/* This version requires t and u tables to be parallel. This
restriction would not be necessary, but it simplifies things
greatly and we only have to store times in the values matrix
and the slowness values in the slopes matrix. */
ttable->nx = pfget_int(pf, "nx");
ttable->nz = pfget_int(pf, "nz");
utable->nx = ttable->nx;
utable->nz = ttable->nz;
ttable->dx = pfget_double(pf, "dx");
ttable->dz = pfget_double(pf, "dz");
utable->dx = ttable->dx;
utable->dz = ttable->dz;
/* These parameters default to 0 */
if(pfget_string(pf,"x0")==NULL)
{
ttable->x0 = 0.0;
utable->x0 = 0.0;
}
else
{
ttable->x0 = pfget_double(pf,"x0");
utable->x0 = ttable->x0;
}
if(pfget_string(pf,"z0")==NULL)
{
ttable->z0 = 0.0;
utable->z0 = 0.0;
}
else
{
ttable->z0 = pfget_double(pf,"z0");
utable->z0 = ttable->z0;
}
/* IMPORTANT WARNING: notice I only alloc one space for the
slowness values array, although it gets placed in two different
places -> values section of utable and slopes section of ttable
This leaves a nasty dependency if this space is to be freed, but
saves a lot of memory. p.s I did the same thing with velocity,
but not with the branch array (see below) */
ttable->values = dmatrix(0,(ttable->nx)-1,0,(ttable->nz)-1);
if(ttable->values == NULL)
elog_die(1,"Cannot alloc memory for travel time table of size %d by %d for phase %s\n",
ttable->nx, ttable->nz, phase);
ttable->slopes = dmatrix(0,(ttable->nx)-1,0,(ttable->nz)-1);
if(ttable->slopes == NULL)
elog_die(1,"Cannot alloc memory for slowness table of size %d by %d for phase %s\n",
ttable->nx, ttable->nz, phase);
ttable->branch = cmatrix(0,(ttable->nx)-1,0,(ttable->nz)-1);
if(ttable->branch == NULL)
elog_die(1,"Cannot alloc memory for time branch table for phase %s\n",
phase);
utable->branch = cmatrix(0,(utable->nx)-1,0,(utable->nz)-1);
if(utable->branch == NULL)
elog_die(1,"Cannot alloc memory for slowness branch table for phase %s\n",
phase);
ttable->velocity = (double *) calloc(ttable->nz,sizeof(double));
if(ttable->velocity == NULL)
elog_die(1,"Cannot alloc memory for velocity model for phase %s\n",
phase);
utable->slopes = dmatrix(0,(utable->nx)-1,0,(utable->nz)-1);
if(utable->slopes == NULL)
elog_die(1,"Cannot alloc memory for dudr table of size %d by %d for phase %s\n",
utable->nx, utable->nz, phase);
/* here is where we set the redundant pointers */
utable->values = ttable->slopes;
utable->velocity = ttable->velocity;
/* Now it is time to actually parse the tables. We assume the
table is entered as a pf &Tbl, and table is scanned with x
varying most rapidly. (i.e. you get the tables for x=x0 first,
then x=x0+dx, etc. Note we read three entries for each grid
point: time, slowness, branch_code */
t = pfget_tbl(pf,"uniform_grid_time_slowness_table");
if(t == NULL)
{
elog_log(1,"Can't find travel time-slowness table for phase %s\n",
phase);
free_uniform_table(ttable, utable);
return(1);
}
if( maxtbl(t) != ( (ttable->nx)*(ttable->nz) ) )
{
elog_log(1,"Table size mismatch for phase %s\nTable should have %d rows\nFound %ld\n",
phase, (ttable->nx)*(ttable->nz), maxtbl(t));
free_uniform_table(ttable, utable);
return(1);
}
for(j=0,k=0; j<ttable->nz; ++j)
{
for(i=0; i<ttable->nx; ++i)
{
char *s;
int nitems;
double tt,u,dudx;
char b;
s = gettbl(t,k);
nitems = sscanf(s,"%lf%lf%lf%1s",
&tt, &u, &dudx,&b);
if(nitems !=4)
{
elog_log(1,"Syntax error reading table for phase %s, Problem read value for i=%d, j=%d\n",
phase,i,j);
free_uniform_table(ttable, utable);
return(1);
}
ttable->values[i][j] = tt;
ttable->slopes[i][j] = u;
utable->slopes[i][j] = dudx;
ttable->branch[i][j] = b;
++k;
}
}
/* In order to utilize a common set of interpolation routines,
scan the time->branch matrix. Mark the crossover points for
time as jump discontinuities for slowness (which they are) */
for(j=0; j<ttable->nz; ++j)
for(i=0; i<ttable->nx; ++i)
if(ttable->branch[i][j] == CROSSOVER)
utable->branch[i][j] = JUMP;
else
utable->branch[i][j] = ttable->branch[i][j];
/* An error check is needed here so we don't have to worry about it
later. Other than a blunder, this can happen if x0 is anything
other than 0, so we need to watch for this. We could try to
repair this automatically, but because it mostly likely indicates
a serious blunder we abort */
for(j=0; j<ttable->nz; ++j)
if( (utable->branch[0][j] == CROSSOVER)
|| (ttable->branch[0][j] == CROSSOVER)
|| (utable->branch[0][j] == JUMP)
|| (ttable->branch[0][j] == JUMP) )
{
elog_log(1,
"Error in travel time table for phase %s\nFirst point cannot be marked as a crossover or jump discontinuity\n",phase);
free_uniform_table(ttable, utable);
return(1);
}
/* Now we read the velocity model parameters */
t = pfget_tbl(pf,"velocities");
if((ttable->nz) != maxtbl(t))
{
elog_log(1,"Error in phase parameter file. \
Mismatch between velocity entries and table entries\n\
Tables have %d depth entries, but velocity vector is of length %ld\n",
ttable->nz, maxtbl(t));
free_uniform_table(ttable,utable);
return(1);
}
for(i=0; i<maxtbl(t); ++i)
{
char *s;
s = gettbl(t,i);
sscanf(s,"%lf", &(ttable->velocity[i]));
}
setarr(time_tables_uniform,phase,ttable);
setarr(slow_tables_uniform,phase,utable);
return(0);
}
int liss_ucompress( int *data,
int pktsize,
int doff,
char *indata,
ushort_t nsamp,
uchar_t dtype )
{
register int lp,ct;
register int *oarray, l_data;
int ret;
Steim *conf ;
int *sud, npts;
oarray=(int *) data;
ct=0;
switch ( dtype ) {
case 1:
case 32:
for (lp=0; lp<nsamp; lp+=2) {
register short j;
j = (indata[lp] & 0xFF) << 8;
j |= (indata[lp+1] & 0xFF);
*oarray++ = (int) j;
ct++;
}
return(ct);
case 3:
for (lp=0; lp<nsamp; lp+=4) {
register int *pt;
pt = (int *) &indata[lp];
*oarray++ = *pt;
ct++;
}
return(ct);
case 10:
conf = ( Steim *) newsteim();
conf->record = indata;
conf->record_size = pktsize-doff;
conf->sdh.data_offset = 0;
conf->sdh.nsamp = nsamp;
conf->level = 1;
if ( usteim (conf, &sud, &npts) ) {
elog_log(0, "unstuffqorbpkt: usteim() error.\n");
return (0);
}
memcpy (data, sud, nsamp*4);
conf->record = 0;
freesteim(conf);
return (nsamp*4);
case 11:
conf = ( Steim *) newsteim();
conf->record = indata;
conf->record_size = pktsize-doff;
conf->sdh.data_offset = 0;
conf->sdh.nsamp = nsamp;
conf->level = 2;
if ( usteim (conf, &sud, &npts) ) {
elog_log(0, "unstuffqorbpkt: usteim() error.\n");
return (0);
}
memcpy (data, sud, nsamp*4);
conf->record = 0;
freesteim(conf);
return (nsamp*4);
case 16:
case 33:
for (lp=0; lp<(nsamp*2); lp+=2) {
register short j;
register int gr;
j = ( indata[lp] & 0x3F) << 8;
j |= ( indata[lp+1] & 0xFF);
j -= 8191;
l_data = (int) j;
gr = ( indata[lp] & 0xC0) >> 6;
switch(gr) {
case 1:
l_data <<= 2;
break;
case 2:
l_data <<= 4;
break;
case 3:
l_data <<= 7;
break;
}
*oarray++ = l_data;
ct++;
}
return(ct);
case 20:
conf = ( Steim *) newsteim();
conf->record = indata;
conf->record_size = pktsize-doff;
conf->sdh.data_offset = 0;
conf->sdh.nsamp = nsamp;
conf->level = 2;
if ( usteim (conf, &sud, &npts) ) {
elog_log(0, "unstuffqorbpkt: usteim() error.\n");
return (0);
}
memcpy (data, sud, nsamp*4);
conf->record = 0;
freesteim(conf);
return (nsamp*4);
case 30:
for (lp=0; lp<(nsamp*2); lp+=2) {
register int j, gr;
j = (indata[lp] & 0x0F) << 8;
j |= (indata[lp+1] & 0xFF);
if (j >= 0x800) j -= 4096;
gr = (indata[lp] & 0xF0) >> 4;
l_data = (int) j;
l_data <<= (10-gr);
*oarray++ = l_data;
ct++;
}
return ct;
case 50:
for (lp=0; lp<nsamp; lp++) {
*oarray++ = indata[lp];
ct++;
}
return(ct);
default:
elog_complain(0, "unknown data format %c\n", dtype );
return -1;
break;
}
}
/* This routine computes standard and nonstandard earthquake location
error estimates. standard error estimate returned is the covariance
matrix of the predicted errors that can be used to derive standard
error ellipses. The covariance that is returned is unscaled. It is the
true covariance only when the weights are ideal 1/sigma weighting.
(Note residual (robust) weighting does not really alter this as the goal
of residual weighting is to downweight outliers and reshape the residual
distribution to be closer to a normal disltribution.
The nonstandard error that is returned is the "model error" defined
in Pavlis (1986) BSSA, 76, 1699-1717.
It would be preferable in some ways to split these into two modules, but
it is more efficient to compute them together.
Arguments:
-input-
h - hypocenter location of point to appraise errors from
attbl- Associate array of Arrival structures
utbl - associate array of slowness structures
o- Location options structure
-output-
C - 4x4 covariance matrix. Assumed allocated externally and
passed here. alloc with modified numerical recipes "matrix" routine.
emodel - 4 vector of x,y,z model error estimates
Both error estimates have 0 in positions where fix is set.
Returns 0 if no problems are encountered. Nonzero return
indicates a problem.
+1 - Inverse matrix was singular to machine precision, error results
are unreliable as svd truncation was need to stabilize
calculations.
Author: Gary L. Pavlis
Written: June 25, 1998
*/
void predicted_errors(Hypocenter h,
Tbl *attbl, Tbl *utbl,
Location_options o,
double **C, float *emodel)
{
Arrival *atimes;
Slowness_vector *slow;
int natimes;
int nslow;
int npar, nused, ndata_feq;
float **U, **V, s[4]; /* SVD of A = USVT */
float **Agi; /* holds computed generalized inverse */
float *b; /* weighted residual vector (rhs of Ax=b)*/
float *r,*w; /* r=raw residual and w= vector of total weights */
float *reswt; /* we store residual weights seperately to calculate
effective degrees of freedom */
int m; /* total number of data points = natimes+2*nslow */
Robust_statistics statistics;
int mode;
int i,ii,j;
/* because o is a dynamic variable, we force the
plain pseudoinverse soltuion */
o.generalized_inverse = PSEUDOINVERSE;
natimes = maxtbl(attbl);
nslow = maxtbl(utbl);
m = 2*nslow + natimes;
for(i=0,npar=0;i<4;++i)
if(!o.fix[i]) ++npar;
Agi = matrix(0,3,0,m-1);
U = matrix(0,m-1,0,3);
V = matrix(0,3,0,3);
b=(float *)calloc(m,sizeof(float));
r=(float *)calloc(m,sizeof(float));
w=(float *)calloc(m,sizeof(float));
reswt=(float *)calloc(m,sizeof(float));
if ( (b==NULL) || (r==NULL)
|| (w==NULL) || (reswt==NULL) )
elog_die(1,"Alloc errors in location error function\n");
statistics = form_equations(ALL, h, attbl,utbl,
o, U, b, r, w, reswt,&ndata_feq);
svdcmp(U,m,npar,s,V);
/* This computes the generalized inverse as the pseudoinverse.
This version forces this to be the true pseudoinverse no
matter what the user selected as a location option. This is
my (glp) prejudice that reporting anything else is a lie.*/
nused = pseudoinverse(U,s,V,m,npar,Agi);
if(nused != npar )
{
elog_log(0,"predicted_errors function found system of equations was singular, Errors estimates are unreliable\n");
}
compute_covariance(Agi,m,npar,4,C,o.fix);
/* Now we compute the emodel vector defined in
Pavlis (1986) BSSA, 76, 1699-1717. A complication is that
we need to do a complex rescan of the arrival and slowness
data tables. This is necessary to allow different
bounding terms for different phases and to obtain most
easily the computed travel time to each stations.
We just recompute the travel times and use an associated
scale factor. For slowness we just enter a fixed value
under and assumption slowness errors do not increase
with distance as travel times tend to do. */
mode = RESIDUALS_ONLY;
for(i=0;i<natimes;++i)
{
Travel_Time_Function_Output tto;
atimes = (Arrival *) gettbl(attbl,i);
tto = calculate_travel_time(*atimes, h,mode);
if(tto.time == TIME_INVALID)
b[i] = 0.0;
else
{
b[i] = tto.time;
b[i] *= w[i]*reswt[i]*atimes->phase->deltat_bound;
}
}
for(i=0,j=natimes;i<nslow;++i,j+=2)
{
slow = (Slowness_vector *) gettbl(utbl,i);
b[j] = slow->phase->deltau_bound;
b[j+1]=b[j];
}
/* we recycle w here blindly assuming m>n */
compute_emodel(Agi, m, npar, b, w);
for(i=0,ii=0;i<4;++i)
if(o.fix[i])
emodel[i] = 0.0;
else
{
emodel[i] = b[ii];
++ii;
}
free_matrix((char **)Agi,0,3,0);
free_matrix((char **)U,0,m-1,0);
free_matrix((char **)V,0,3,0);
free(b);
free(r);
free(w);
free(reswt);
}
/* This function computes the attributes of the predarr table.
This is seriously complicated by the fact that the timedef and
slowdef attributes in the css3.0 schema allow independently turning
off time and slowness residuals. The way we solve this here is to
first save results for all the entries in the Arrival tbl keeping
a temporary list of all the arid values found in the Arrival tbl.
We then use a stupid linear search algorithm against each arid found
in the Slowness_vector table and only compute a new predarr row if
the arid found for that Slowness vector did not match any found in arid.
The linear search is acceptable here under an assumption that arrival
data will outnumber slowness vector measurements in most locations.
This algorithm looks for the stavel table that is also defined in the
takeoff schema extensions. This table defines surface velocities to
use in computing emergence angles (ema). If an entry is not found
for a given phase in stavel, the program tries to decide if this is a
P or S phase (by looking at the last character in the phase name) and
using a default (hardwired below). This will generate a complain error
because the values in predarr are not necessarily consistent with vmodel
in this situation.
arguments:
db - database to save results to
atbl - Tbl of Arrival structures used in genloc
utbl - Tbl of Slowness_vector structures comparable to a
h - hypocenter estimate to be used to compute predarr rows
orid - orid database id assigned to this solution.
vmodel - name of velocity model being used (key of stavel)
Returns 0 for success, anything else indicates and error. A positive
return indicates the number of warning messages issued. A negative
return indicates nothing was written because the predarr table could
not be written due to either: (1) undefined in the schema or (2)
table is not writeable.
Author: G Pavlis
*/
int save_predarr( Dbptr db, Tbl *atbl, Tbl *utbl,
Hypocenter h, int orid, char *vmodel)
{
int natimes;
int nslow;
long *allarids;
int errors=0;
Arrival *atimes;
Arrival a;
Station station;
Slowness_vector *slow;
Slowness_vector u;
Seismic_Array sta_array;
Travel_Time_Function_Output tto;
Slowness_Function_Output u_calc;
/* These are the fields computed here and saved in predarr */
double time, utotal, seaz, esaz, ema, dip;
int stavel_ok; /* set to 1 if stavel is found valid. Function
returns immediately if the predarr table is not defined */
double ema_null=-1.0;
int i,k;
if(dbtable_invalid(db,"predarr"))
{
elog_log(0,"predarr table not defined in schema for this database\n");
return(-1);
}
if(dbtable_invalid(db,"stavel"))
{
elog_log(0,"stavel table is not defined. Using defaults for all stations and phases\n");
stavel_ok = 0;
}
else if(dbtable_empty(db,"stavel"))
{
stavel_ok=0; /* do this silently */
}
else
{
stavel_ok = 1;
/* This is the correct way to find the null value for a field*/
db = dblookup(db,0,"predarr",0,0);
db.record = dbNULL;
dbgetv(db,0,"ema",&ema_null,NULL );
}
natimes = maxtbl(atbl);
nslow = maxtbl(utbl);
if(natimes > 0)
{
allarids = (long *)calloc(natimes,sizeof(long));
if(allarids == NULL) elog_die(0,"save_predarr cannot alloc %d long integers\n",
natimes);
}
/* These quantities need to be explicitly initialized at the top
of this loop. They stay fixed for the whole loop. Only the
sta_array set really matters. */
u.ux = 0.0;
u.uy = 0.0;
u.array = &sta_array;
db = dblookup(db,0,"predarr",0,0);
for(i=0;i<natimes;++i)
{
atimes = (Arrival *) gettbl(atbl,i);
/* discard - phases as predarr makes no sense for them */
if(strstr(atimes->phase->name,"-")!=NULL) continue;
allarids[i] = atimes->arid;
tto = calculate_travel_time(*atimes,h,ALL);
if(tto.time == TIME_INVALID)
{
elog_log(0,"save_predarr failed to compute predicted arrival times for station %s and phase %s\n",
atimes->sta->name, atimes->phase->name);
++errors;
continue;
}
time = h.time + tto.time;
dip = compute_dip(tto);
esaz = compute_esaz(tto);
/* This loads a fake slowness vector for each station.
Note this is different from the location code and could
fail in some situations when the location computation
did not. In those situations, slow, ema, and esaz
cannot be computed. */
u.arid = atimes->arid;
strcpy(u.array->name,atimes->sta->name);
u.array->lat = atimes->sta->lat;
u.array->lon = atimes->sta->lon;
u.array->elev = atimes->sta->elev;
u.phase = atimes->phase;
u_calc = calculate_slowness_vector(u,h,RESIDUALS_ONLY);
if(u_calc.ux == SLOWNESS_INVALID)
{
elog_log(0,"predarr failed to compute slowness vector for station %s and phase %s\n",
atimes->sta->name, atimes->phase->name);
++errors;
if(dbaddv(db,0,
"arid",atimes->arid,
"orid",orid,
"time",time,
"esaz",esaz,
"dip",dip,
NULL ) == dbINVALID)
{
elog_log(0,"dbaddv on predarr table for station %s and phase %s\n",
atimes->sta->name, atimes->phase->name);
++errors;
}
}
else
{
utotal = hypot(u_calc.ux,u_calc.uy);
/* css3.0 stores slowness is s/deg so we have
to convert */
utotal *= KMPERDEG;
seaz = compute_seaz(u_calc);
if(stavel_ok) ema = compute_ema(&u,&u_calc,db,vmodel);
if(ema < 0.0) ema = ema_null;
if(dbaddv(db,0,
"arid",atimes->arid,
"orid",orid,
"time",time,
"slow",utotal,
"seaz",seaz,
"ema", ema,
"esaz",esaz,
"dip",dip,
NULL ) == dbINVALID)
{
elog_log(0,"dbaddv on predarr table for station %s and phase %s\n",
atimes->sta->name, atimes->phase->name);
++errors;
}
}
}
/* Nww we have to hunt for slowness measurements that have not
travel time computed above. Here we used a dumb linear search
against arid for reasons give above. The rest of the algorithm
closely parallels the above loop, except the role of arrival
and slowness are reversed. */
a.time = 0.0;
a.sta = &station;
for(i=0;i<nslow;i++)
{
slow = (Slowness_vector *) gettbl(utbl,i);
for(k=0;k<natimes;k++)
if(allarids[k] == slow->arid) break;
if(k>=natimes)
{
/* Only when the above search fails will we actually do anything
in this loop */
a.arid = slow->arid;
strcpy(a.sta->name,slow->array->name);
a.sta->lat = slow->array->lat;
a.sta->lon = slow->array->lon;
a.sta->elev = slow->array->elev;
a.phase = slow->phase;
tto = calculate_travel_time(a,h,ALL);
if(tto.time == TIME_INVALID)
{
elog_log(0,"save_predarr failed to compute predicted arrival times for station %s and phase %s\n",
atimes->sta->name, atimes->phase->name);
++errors;
continue;
}
time = h.time + tto.time;
dip = compute_dip(tto);
u_calc = calculate_slowness_vector(*slow,h,RESIDUALS_ONLY);
if(u_calc.ux == SLOWNESS_INVALID)
{
elog_log(0,"predarr failed to compute slowness vector for station %s and phase %s\n",
atimes->sta->name, atimes->phase->name);
++errors;
if(dbaddv(db,0,
"arid",atimes->arid,
"orid",orid,
"time",time,
"esaz",esaz,
"dip",dip,
NULL ) == dbINVALID)
{
elog_log(0,"dbaddv on predarr table for station %s and phase %s\n",
atimes->sta->name, atimes->phase->name);
++errors;
}
}
else
{
utotal = hypot(u_calc.ux,u_calc.uy);
utotal *= KMPERDEG;
seaz = compute_seaz(u_calc);
if(stavel_ok) ema = compute_ema(&u,&u_calc,db,vmodel);
if(ema < 0.0) ema = ema_null;
if(dbaddv(db,0,
"arid",atimes->arid,
"orid",orid,
"time",time,
"slow",utotal,
"seaz",seaz,
"ema", ema,
"esaz",esaz,
"dip",dip,
NULL ) == dbINVALID)
{
elog_log(0,"dbaddv on predarr table for station %s and phase %s\n",
atimes->sta->name, atimes->phase->name);
++errors;
}
}
}
}
free(allarids);
return(errors);
}
int
grdb_sc_loadcss (Dbptr dbin, char *net_expr, char *sta_expr, char *chan_expr, double tstart, double tend,
int coords, int ir, int orient, Dbptr *dbscgr, Dbptr *dbsc)
/*
Dbptr dbin;
char * net_expr;
char * sta_expr;
char * chan_expr;
double tstart, tend;
int coords, ir, orient;
Dbptr * dbscgr;
Dbptr * dbsc;
*/
{
Dbptr dbout, db, dbout2;
char string[1024];
char string2[1024];
char sta_wfdisc[32], chan_wfdisc[32];
int i, j, n, sensor=0, ok;
Tbl *pat1, *pat2;
Tbl *sortfields, *groupfields;
FILE *file;
Response *resp;
/* Subset the wfdisc by station-channel-time sifters. */
dbout = dblookup (dbin, 0, "wfdisc", 0, 0);
strcpy (string, "");
if (sta_expr) {
strcpy (string, "( ");
sprintf (string2, "sta =~ /%s/", sta_expr);
strcat (string, string2);
}
if (chan_expr) {
if (string[0]) strcat (string, " && ");
else strcpy (string, "( ");
sprintf (string2, "chan =~ /%s/", chan_expr);
strcat (string, string2);
}
if (tstart != 0.0 || tend != 0.0) {
if (string[0]) strcat (string, " && ");
else strcpy (string, "( ");
sprintf (string2, "(time < %.5f && endtime > %.5f)", tend, tstart);
strcat (string, string2);
}
if (string[0]) {
strcat (string, " )");
dbout = dbsubset (dbout, string, 0);
}
dbquery (dbout, dbRECORD_COUNT, &n);
if (n < 1) {
elog_log(0, "grdb_sc_loadcss: No wfdisc rows to process.\n");
return (-1);
}
/* Make the necessary joins and check for completeness. */
if (coords) {
db = dblookup (dbin, 0, "site", 0, 0);
dbout = dbjoin (dbout, db, 0, 0, 1, 0, 0);
dbquery (dbout, dbRECORD_COUNT, &n);
if (n < 1) {
elog_log(0, "grdb_sc_loadcss: No data rows to process.\n");
return (-1);
}
for (dbout.record=0; dbout.record<n; dbout.record++) {
if (dbgetv (dbout, 0, "wfdisc.sta", sta_wfdisc,
"wfdisc.chan", chan_wfdisc,
"site.sta", string, 0) == dbINVALID) {
elog_log(0, "grdb_sc_loadcss: dbgetv() error while checking site.\n");
return (-1);
}
if (coords > 1 && strcmp(string, sta_wfdisc)) {
elog_log(0, "grdb_sc_loadcss: Cannot find site parameters for %s %s.\n",
sta_wfdisc, chan_wfdisc);
return (-1);
}
}
}
if (ir) {
db = dblookup (dbin, 0, "sensor", 0, 0);
dbout = dbjoin (dbout, db, 0, 0, 1, 0, 0);
dbquery (dbout, dbRECORD_COUNT, &n);
if (n < 1) {
elog_log(0, "grdb_sc_loadcss: No data rows to process.\n");
return (-1);
}
for (dbout.record=0; dbout.record<n; dbout.record++) {
if (dbgetv (dbout, 0, "wfdisc.sta", sta_wfdisc,
"wfdisc.chan", chan_wfdisc,
"sensor.sta", string, 0) == dbINVALID) {
elog_log(0, "grdb_sc_loadcss: dbgetv() error while checking sensor.\n");
return (-1);
}
if (ir > 1 && strcmp(string, sta_wfdisc)) {
elog_log(0, "grdb_sc_loadcss: Cannot find sensor parameters for %s %s.\n",
sta_wfdisc, chan_wfdisc);
return (-1);
}
}
sensor = 1;
db = dblookup (dbin, 0, "instrument", 0, 0);
dbout = dbjoin (dbout, db, 0, 0, 1, 0, 0);
dbquery (dbout, dbRECORD_COUNT, &n);
if (n < 1) {
elog_log(0, "grdb_sc_loadcss: No data rows to process.\n");
return (-1);
}
for (dbout.record=0; dbout.record<n; dbout.record++) {
if (dbgetv (dbout, 0, "wfdisc.sta", sta_wfdisc,
"wfdisc.chan", chan_wfdisc,
"sensor.inid", &j,
"instrument.insname", string2,
"instrument.inid", &i, 0) == dbINVALID) {
elog_log(0, "grdb_sc_loadcss: dbgetv() error while checking instrument.\n");
return (-1);
}
if (ir > 1 && (i != j)) {
elog_log(0, "grdb_sc_loadcss: Cannot find instrument parameters for %s %s.\n",
sta_wfdisc, chan_wfdisc);
return (-1);
}
if (i >= 0) {
if (resp_arr == NULL) {
resp_arr = newarr (0);
if (resp_arr == NULL) {
elog_log(0, "grdb_sc_loadcss: newarr() error.\n");
return (-1);
}
}
dbextfile (dbout, "instrument", string);
resp = (Response *) getarr (resp_arr, string);
if (resp == NULL) {
file = fopen (string, "r");
if (file == NULL) {
if (ir > 1) {
elog_log(1, "grdb_sc_loadcss: fopen('%s') error.\n", string);
return (-1);
}
} else {
if (read_response (file, &resp)) {
elog_log(0, "grdb_sc_loadcss: read_response('%s') error.\n", string);
return (-1);
}
fclose (file);
resp->insname = strdup(string2);
}
setarr (resp_arr, string, resp);
}
}
}
}
if (orient) {
ok = 1;
db = dblookup (dbin, 0, "sitechan", 0, 0);
dbout2 = dbjoin (dbout, db, 0, 0, 1, 0, 0);
dbquery (dbout2, dbRECORD_COUNT, &n);
if (n < 1) {
ok = 0;
} else {
for (dbout2.record=0; dbout2.record<n; dbout2.record++) {
dbgetv (dbout2, 0, "wfdisc.sta", sta_wfdisc,
"wfdisc.chan", chan_wfdisc,
"sitechan.sta", string, 0);
if (strcmp(string, sta_wfdisc)) {
ok = 0;
break;
}
}
}
if (ok) {
dbout = dbout2;
} else {
if (!sensor) {
db = dblookup (dbin, 0, "sensor", 0, 0);
dbout = dbjoin (dbout, db, 0, 0, 1, 0, 0);
dbquery (dbout, dbRECORD_COUNT, &n);
if (n < 1) {
elog_log(0, "grdb_sc_loadcss: No data rows to process.\n");
return (-1);
}
for (dbout.record=0; dbout.record<n; dbout.record++) {
if (dbgetv (dbout, 0, "wfdisc.sta", sta_wfdisc,
"wfdisc.chan", chan_wfdisc,
"sensor.sta", string, 0) == dbINVALID) {
elog_log(0, "grdb_sc_loadcss: dbgetv() error while checking sensor.\n");
return (-1);
}
if (orient > 1 && strcmp(string, sta_wfdisc)) {
elog_log(0, "grdb_sc_loadcss: Cannot find sensor parameters for %s %s.\n",
sta_wfdisc, chan_wfdisc);
return (-1);
}
}
}
db = dblookup (dbin, 0, "sitechan", 0, 0);
pat1 = newtbl(1);
if (pat1 == NULL) {
elog_log(0, "grdb_sc_loadcss: newtbl() error.\n");
return (-1);
}
pat2 = newtbl(1);
if (pat2 == NULL) {
elog_log(0, "grdb_sc_loadcss: newtbl() error.\n");
return (-1);
}
settbl (pat1, 0, strdup("sensor.chanid"));
settbl (pat2, 0, strdup("sitechan.chanid"));
dbout = dbjoin (dbout, db, &pat1, &pat2, 1, 0, 0);
freetbl (pat1, free);
freetbl (pat2, free);
dbquery (dbout, dbRECORD_COUNT, &n);
if (n < 1) {
elog_log(0, "grdb_sc_loadcss: No data rows to process.\n");
return (-1);
} else {
for (dbout.record=0; dbout.record<n; dbout.record++) {
if (dbgetv (dbout, 0, "wfdisc.sta", sta_wfdisc,
"wfdisc.chan", chan_wfdisc,
"sitechan.sta", string, 0) == dbINVALID) {
elog_log(0, "grdb_sc_loadcss: dbgetv() error while checking sitechan.\n");
return (-1);
}
if (orient > 1 && strcmp(string, sta_wfdisc)) {
elog_log(0, "grdb_sc_loadcss: Cannot find sitechan parameters for %s %s.\n",
sta_wfdisc, chan_wfdisc);
return (-1);
}
}
}
}
}
/* Sort and group the output view. */
sortfields = newtbl (3);
if (sortfields == NULL) {
elog_log(0, "grdb_sc_loadcss: newtbl() error.\n");
return (-1);
}
settbl (sortfields, 0, strdup("wfdisc.sta"));
settbl (sortfields, 1, strdup("wfdisc.chan"));
settbl (sortfields, 2, strdup("wfdisc.time"));
*dbsc = dbsort (dbout, sortfields, 0, 0);
groupfields = newtbl (2);
if (groupfields == NULL) {
elog_log(0, "grdb_sc_loadcss: newtbl() error.\n");
return (-1);
}
settbl (groupfields, 0, strdup("sta"));
settbl (groupfields, 1, strdup("chan"));
*dbscgr = dbgroup (*dbsc, groupfields, 0, 1);
freetbl (sortfields, free);
freetbl (groupfields, free);
/* Normal exit */
return (0);
}
