void do_lag( char_data* ch, char* argument )
{
char tmp [ ONE_LINE ];
int sum;
int flags;
int i, j;
int list [ 50 ];
float value [ 50 ];
int length = strlen( argument );
if( !get_flags( ch, argument, &flags, "hr", "Lag" ) )
return;;
if( is_set( &flags, 0 ) ) {
for( sum = 0, i = 0; i < 10; i++ )
sum += time_history[i];
send_underlined( ch,
"Sec. of Delay # of Cycles Percent\r\n" );
for( j = 0, i = 0; i < 10; i++, j = ( j == 0 ? 1 : 2*j ) ) {
sprintf( tmp, "%.1f", (float) j/10 );
sprintf( tmp+10, "%8s %21d %16.2f\r\n", i == 0 ? "none" :
( i == 9 ? "more" : tmp ), time_history[i],
(float) 100*time_history[i]/sum );
send( tmp+10, ch );
}
return;
}
page_underlined( ch,
"Command Calls Average Max Time Total\r\n" );
if( is_set( &flags, 1 ) ) {
vzero( list, 50 );
vzero( value, 50 );
for( i = 0; i < MAX_ENTRY_COMMAND; i++ )
order( list, value, i, command_table[i].total_time.time() );
for( i = 0; i < 50; i++ )
display_lag( ch, list[i] );
return;
}
for( i = 0; i < MAX_ENTRY_COMMAND; i++ )
if( !strncasecmp( command_table[i].name, argument, length ) )
display_lag( ch, i );
return;
}
void
getcolxf(double *xcol, SNP *cupt, int *xindex, int nrows, int col,
double *xmean, double *xfancy)
// side effect set xmean xfancy
{
int n ;
double pmean, yfancy ;
int *rawcol ;
if (xmean != NULL) {
xmean[col] = xfancy[col] = 0.0 ;
}
if (cupt -> ignore) {
vzero(xcol, nrows) ;
return ;
}
ZALLOC(rawcol, nrows, int) ;
n = cupt -> ngtypes ;
if (n<nrows) fatalx("bad snp: %s %d\n", cupt -> ID, n) ;
getrawcol(rawcol, cupt, xindex, nrows) ;
floatit(xcol, rawcol, nrows) ;
fvadjust(xcol, nrows, &pmean, &yfancy) ;
vst(xcol, xcol, yfancy, nrows) ;
if (xmean != NULL) {
xmean[col] = pmean*yfancy ;
xfancy[col] = yfancy ;
}
free(rawcol) ;
}
void cholesky(double *cf, double *a, int n)
{
int i, j, k ;
double *tt ;
double *p ;
ZALLOC(tt, n*n, double) ;
ZALLOC(p, n, double) ;
copyarr(a,tt,n*n);
choldc(tt, n, p ) ;
vzero(cf, n*n) ;
for (i = 0; i < n; i++) {
tt[i*n+i] = p[i] ;
for (j=0; j <= i ; j++) {
k = (i)*n+(j) ;
cf[k] = tt[i*n+j] ;
}
}
free(tt) ;
free(p) ;
}
/*
* Ok, simulate a track-ball. Project the points onto the virtual
* trackball, then figure out the axis of rotation, which is the cross
* product of P1 P2 and O P1 (O is the center of the ball, 0,0,0)
* Note: This is a deformed trackball-- is a trackball in the center,
* but is deformed into a hyperbolic sheet of rotation away from the
* center. This particular function was chosen after trying out
* several variations.
*
* It is assumed that the arguments to this routine are in the range
* (-1.0 ... 1.0)
*/
static void
trackball ( float q[4], float p1x, float p1y, float p2x, float p2y )
{
float a[3]; /* Axis of rotation */
float phi; /* how much to rotate about axis */
float p1[3], p2[3], d[3];
float t;
if (p1x == p2x && p1y == p2y)
{
// Zero rotation
vzero(q);
q[3] = 1.0;
return;
}
// First, figure out z-coordinates for projection of P1 and P2 to
// deformed sphere
vset(p1,p1x,p1y,tb_project_to_sphere(TRACKBALLSIZE,p1x,p1y));
vset(p2,p2x,p2y,tb_project_to_sphere(TRACKBALLSIZE,p2x,p2y));
// Now, we want the cross product of P1 and P2
vcross(p2,p1,a);
// Figure out how much to rotate around that axis.
vsub(p1,p2,d);
t = vlength(d) / (2.0*TRACKBALLSIZE);
// Avoid problems with out-of-control values...
if (t > 1.0) t = 1.0;
if (t < -1.0) t = -1.0;
phi = 2.0 * asin(t);
axis_to_quat(a,phi,q);
}
void sum2D(double *a, double **b, int nrows, int ncols)
{
int x ;
vzero(a, ncols) ;
for (x=0; x < nrows; ++x) {
vvp(a, a, b[x], ncols) ;
}
}
void setidmat(double *a, int n)
// a <- identity matrix
{
int i ;
vzero(a, n*n) ;
for (i=0; i<n; i++) {
a[i*n+i] = 1.0 ;
}
}
int
ri_transport_whitted(
ri_render_t *render,
const ri_ray_t *ray,
ri_transport_info_t *result)
{
ri_ray_t eyeray;
ri_intersection_state_t state;
/*
* Initialize
*/
{
ri_vector_setzero(result->radiance);
result->nbound_diffuse = 0;
result->nbound_specular = 0;
ri_intersection_state_clear( &result->state );
memcpy(&eyeray, ray, sizeof(ri_ray_t));
}
/*
* Shoot eye ray.
*/
int hit;
int ret;
hit = ri_raytrace(render, &eyeray, &state);
if (hit) {
trace_whitted(render, &state, result, 1);
} else {
/*
* If the scene has envmap, add contribution from the envmap.
*/
if (render->scene->envmap_light) {
ri_texture_ibl_fetch(result->radiance,
render->scene->envmap_light->texture,
eyeray.dir);
} else {
vzero(result->radiance);
}
}
return 0; /* OK */
}
static void trace_whitted(
ri_render_t *render,
ri_intersection_state_t *isect,
ri_transport_info_t *result,
int depth)
{
double eps = 1.0e-7;
int hit;
ri_intersection_state_t state;
ri_ray_t Rr;
vec Rd;
ri_ray_t Tr;
vec Td;
ri_float_t eta = 1.33;
if (depth > MAX_TRACE_DEPTH) {
return;
}
//ri_reflect(Rd, isect->I, isect->Ns);
ri_refract(Rd, isect->I, isect->Ns, 1.33);
vcpy(Rr.dir, Rd);
Rr.org[0] = isect->P[0] + eps * Rd[0];
Rr.org[1] = isect->P[1] + eps * Rd[1];
Rr.org[2] = isect->P[2] + eps * Rd[2];
hit = ri_raytrace(render, &Rr, &state);
if (hit) {
//vzero(result->radiance);
trace_whitted(render, &state, result, depth + 1);
} else {
/*
* If the scene has envmap, add contribution from the envmap.
*/
if (render->scene->envmap_light) {
ri_texture_ibl_fetch(result->radiance,
render->scene->envmap_light->texture,
Rd);
} else {
vzero(result->radiance);
}
}
}
int runfuse(int argc, const char* const* argv)
{
struct fuse_args fua = FUSE_ARGS_INIT(argc, (char**) argv);
struct cuse_info info;
const char *iav[] = { "DEVNAME=jrandom",NULL };
vzero(info);
info.dev_info_argc = 1;
info.dev_info_argv = iav;
info.flags = CUSE_UNRESTRICTED_IOCTL;
return cuse_lowlevel_main(fua.argc, fua.argv, &info, GET_RNDEV_OPS(), NULL);
}
/** this is the code to parallelize */
void
domult(double *tvecs, double *tblock, int numrow, int len)
{
int i ;
double ycheck ;
vzero(tvecs, len*len) ;
for (i=0; i<numrow; i++) {
ycheck = asum(tblock+i*len, len) ;
if (fabs(ycheck)>.00001) fatalx("bad ycheck\n") ;
addoutersym(tvecs, tblock+i*len, len) ;
}
}
void
setdiag(double *a, double *diag, int n)
/* set diagonal matrix */
{
int i, k ;
vzero(a, n*n) ;
for (i=0; i<n; i++) {
k = i*n+i ;
a[k] = diag[i] ;
}
}
Wizard_Data :: Wizard_Data(char* name) : player_data(name)
{
record_new(sizeof(wizard_data), MEM_WIZARD);
record_delete(sizeof(player_data), MEM_PLAYER);
valid = WIZARD_DATA;
action_edit = NULL;
adata_edit = NULL;
room_edit = NULL;
mpdata_edit = NULL;
mprog_edit = NULL;
oextra_edit = NULL;
opdata_edit = NULL;
oprog_edit = NULL;
player_edit = NULL;
quest_edit = NULL;
obj_edit = NULL;
mob_edit = NULL;
exit_edit = NULL;
custom_edit = 0;
rtable_edit = -1;
list_edit = 0;
office = 0;
wizinvis = 0;
vzero(table_edit, 2);
bamfin = empty_string;
bamfout = empty_string;
level_title = empty_string;
build_chan = NULL;
imm_talk = NULL;
god_talk = NULL;
avatar = NULL;
vzero(permission, 2);
}
void randirichlet(double *x, double *pp, int n)
/**
generate dirichlet r.v. parameters pp
*/
{
int i ;
vzero(x, n) ;
for (i=0; i<n; i++) {
if (pp[i] > 0.0) {
x[i] = rangam(pp[i]) ;
}
}
bal1(x,n) ;
}
void reset_sheet(tectonic_sheet *ts) {
size_t i, j, idx;
for (i = 0; i < sheet_pwidth(ts); ++i) {
for (j = 0; j < sheet_pheight(ts); ++j) {
idx = sheet_pidx(ts, i, j);
ts->points[idx].x = i;
ts->points[idx].y = j * SX_GRID_HEIGHT;
ts->points[idx].z = 0;
if (j % 2 == 1) {
ts->points[idx].x += SX_GRID_OFFSET;
}
vzero(&(ts->forces[idx]));
ts->avgcounts[idx] = 0;
}
}
}
/*
* Ok, simulate a track-ball. Project the points onto the virtual
* trackball, then figure out the axis of rotation, which is the cross
* product of P1 P2 and O P1 (O is the center of the ball, 0,0,0)
* Note: This is a deformed trackball-- is a trackball in the center,
* but is deformed into a hyperbolic sheet of rotation away from the
* center. This particular function was chosen after trying out
* several variations.
*
* It is assumed that the arguments to this routine are in the range
* (-1.0 ... 1.0)
*/
void trackball( double q[4], double p1x, double p1y, double p2x, double p2y )
{
double a[3]; /* Axis of rotation */
double phi; /* how much to rotate about axis */
double p1[3], p2[3], d[3];
double t;
if( p1x == p2x && p1y == p2y )
{
/* Zero rotation */
vzero( q );
q[3] = 1.0;
return;
}
/*
* First, figure out z-coordinates for projection of P1 and P2 to
* deformed sphere
*/
vset( p1, p1x, p1y, tb_project_to_sphere( TRACKBALLSIZE, p1x, p1y ) );
vset( p2, p2x, p2y, tb_project_to_sphere( TRACKBALLSIZE, p2x, p2y ) );
/*
* Now, we want the cross product of P1 and P2
*/
vcross(p2,p1,a);
/*
* Figure out how much to rotate around that axis.
*/
vsub( p1, p2, d );
t = vlength( d ) / (2.0f * TRACKBALLSIZE);
/*
* Avoid problems with out-of-control values...
*/
if( t > 1.0 )
t = 1.0;
if( t < -1.0 )
t = -1.0;
phi = 2.0f * (double) asin( t );
axis_to_quat( a, phi, q );
}
char* coin_phrase( char_data* ch )
{
int coins [ MAX_COIN ];
obj_data* obj;
vzero( coins, MAX_COIN );
for( int i = 0; i < ch->contents; i++ ) {
if( ( obj = object( ch->contents[i] ) ) != NULL
&& obj->pIndexData->item_type == ITEM_MONEY )
for( int j = 0; j < MAX_COIN; j++ )
if( obj->pIndexData->vnum == coin_vnum[j] )
coins[j] += obj->number;
}
return coin_phrase( coins );
}
Share_Data :: Share_Data()
{
record_new(sizeof(share_data), MEM_SHDATA);
strength = 10;
intelligence = 10;
wisdom = 10;
dexterity = 10;
constitution = 10;
deaths = 0;
kills = 0;
level = 0;
fame = 0;
race = RACE_HUMAN;
vzero(resist, MAX_RESIST);
}
void Trackball :: rotateAngle ( float phi, float ax, float ay, float az )
{
float axis[3] = { ax,ay,az } ;
float * q = m_lastquat ;
if (phi == 0 || axis[0] == axis[1] == axis[2] == 0 )
{
// Zero rotation
vzero(q);
q[3] = 1.0;
return;
}
// Convert degrees to radians
phi *= M_PI / 180.0 ;
axis_to_quat(axis,phi,q);
spin() ;
}
/* compute the force, return the potential energy
* the potential is the two bond lengths */
static double force(void)
{
double ep = 0;
int i;
for ( i = 0; i < N; i++ ) {
vzero( f[i] );
}
if ( constraint ) return ep;
/* bonds 0-1 and 0-2 */
for ( i = 1; i < N; i++ ) {
ep += potbond(x[i], x[0], 1.0, kappa, f[i], f[0]);
}
return ep;
}
void clearld(double *ldmat, double *ldvv, int rsize, int n, int nclear)
{
int i, j, lo, hi ;
if (nclear>rsize) fatalx("bad nclear\n") ;
lo = rsize-nclear ;
hi = rsize-1 ;
for (i=lo; i<=hi; ++i) {
vzero(ldvv+i*n, n) ;
for (j=0; j<=hi; ++j) {
ldmat[j*rsize+i] = ldmat[i*rsize+j] = 0.0 ;
}
// force matrix non-singular
ldmat[i*rsize+i] = 1.0e-8 ;
}
}
void
sample_distant_light(
ri_vector_t Lo, /* [out] */
ri_bvh_t *bvh,
const ri_intersection_state_t *isect,
ri_vector_t Ldir, /* normalized */
ri_vector_t Lcol,
int debug)
{
(void)debug;
int hit;
ri_ray_t ray;
ri_intersection_state_t state;
ri_float_t dot;
vcpy(ray.org, isect->P);
ray.org[0] += isect->Ns[0] * 0.00001;
ray.org[1] += isect->Ns[1] * 0.00001;
ray.org[2] += isect->Ns[2] * 0.00001;
vcpy(ray.dir, Ldir);
hit = ri_bvh_intersect( (void *)bvh, &ray, &state, NULL );
if (hit) {
/* There's obscrances between the shading point and the light */
vzero(Lo);
} else {
/* Lo = L cosTheta */
dot = vdot(Ldir, isect->Ns);
if (dot < 0.0) dot = 0.0;
Lo[0] = Lcol[0] * dot;
Lo[1] = Lcol[1] * dot;
Lo[2] = Lcol[2] * dot;
}
}
void vnlisten( u32 port, vncallback cb ){
int s;
struct addrinfo* res = NULL;
struct addrinfo hnts;
if( pvnscks == NULL )
pvninit();
vzero( hnts );
hnts.ai_family = AF_INET;
hnts.ai_socktype = SOCK_STREAM;
hnts.ai_protocol = IPPROTO_TCP;
hnts.ai_flags = AI_PASSIVE;
s = getaddrinfo( NULL, vintToString( port, 0 ), &hnts, &res );
if( s ){
vdie( "getaddrinfo failed!" );
}
{
SOCKET cs;
cs = socket( res->ai_family, res->ai_socktype, res->ai_protocol );
if( cs == INVALID_SOCKET ){
freeaddrinfo( res );
vdie( "socket failed!" );
}
{ int i = 1; setsockopt( cs, SOL_SOCKET, SO_EXCLUSIVEADDRUSE, (char *)&i, sizeof( int ) ); }
pvncheck( "bind failed", bind( cs, res->ai_addr, (int)res->ai_addrlen ), &cs, res );
freeaddrinfo( res );
pvncheck( "listen failed", listen( cs, SOMAXCONN ), &cs, NULL );
pvnaddsock( &cs, cb );
vlogInfo( "Now listening on port " ); vlogInfo( vintToString( port, 0 ) ); vlogInfo( "\n" );
}
}
/*
* Ok, simulate a track-ball. Project the points onto the virtual
* trackball, then figure out the axis of rotation, which is the cross
* product of P1 P2 and O P1 (O is the center of the ball, 0,0,0)
* Note: This is a deformed trackball-- is a trackball in the center,
* but is deformed into a hyperbolic sheet of rotation away from the
* center. This particular function was chosen after trying out
* several variations.
*
* It is assumed that the arguments to this routine are in the range
* (-1.0 ... 1.0)
*/
void trackball(float q[4], float p1x, float p1y, float p2x, float p2y, float tbSize)
{
float a[3]; // Axis of rotation
float phi; // how much to rotate about axis
float p1[3], p2[3], d[3];
float t;
if( p1x == p2x && p1y == p2y ) {
/* Zero rotation */
vzero(q);
q[3] = 1.0;
return;
}
// First, figure out z-coordinates for projection of P1 and P2 to deformed sphere
vset( p1, p1x, p1y, tb_project_to_sphere(tbSize, p1x, p1y) );
vset( p2, p2x, p2y, tb_project_to_sphere(tbSize, p2x, p2y) );
// Now, we want the cross product of P1 and P2
vcross( p2, p1, a);
// Figure out how much to rotate around that axis
vsub( p1, p2, d);
t = vlength(d) / ( 2.0f * tbSize );
// Avoid problems with out-of-control values
if (t > 1.0) {
t = 1.0;
}
if (t < -1.0) {
t = -1.0;
}
phi = 2.0f * (float)asin(t);
axis_to_quat( a, phi, q );
}
int main(int argc, char **argv)
{
char **eglist ;
int numeg ;
int i, j, k, pos;
int *vv ;
SNP *cupt, *cupt2 ;
Indiv *indx ;
double y1, y2, y ;
int n0, n1, nkill ;
int nindiv = 0 ;
int nignore, numrisks = 1 ;
SNP **xsnplist ;
Indiv **xindlist ;
int *xindex ;
int nrows, ncols, m ;
double *XTX, *cc, *evecs, *ww ;
double *lambda ;
double *tvecs ;
int weightmode = NO ;
int t ;
double *xmean, *xfancy ;
double *ldmat = NULL, *ldmat2 = NULL;
double *ldvv = NULL, *ldvv2 = NULL, *vv2 = NULL ;
int chrom, numclear ;
double gdis ;
int outliter, numoutiter, *badlist, nbad ;
int a, b, n ;
FILE *outlfile ;
int xblock, blocksize=10000 ;
double *tblock ;
OUTLINFO *outpt ;
int *idperm, *vecind ; // for sort
readcommands(argc, argv) ;
printf("## smartrel version: %s\n", WVERSION) ;
packmode = YES ;
setomode(&outputmode, omode) ;
if (parname == NULL) return 0 ;
if (xchrom == (numchrom+1)) noxdata = NO ;
if (fstonly) {
printf("fstonly\n") ;
numeigs = 0 ;
numoutliter = 0 ;
numoutiter = 0 ;
outputname = NULL ;
snpeigname = NULL ;
}
if (fancynorm) printf("norm used\n\n") ;
else printf("no norm used\n\n") ;
nostatslim = MAX(nostatslim, 3) ;
outlfile = ofile = stdout;
if (outputname != NULL) openit(outputname, &ofile, "w") ;
if (outliername != NULL) openit(outliername, &outlfile, "w") ;
if (fstdetailsname != NULL) openit(fstdetailsname, &fstdetails, "w") ;
numsnps =
getsnps(snpname, &snpmarkers, 0.0, badsnpname, &nignore, numrisks) ;
numindivs = getindivs(indivname, &indivmarkers) ;
k = getgenos(genotypename, snpmarkers, indivmarkers,
numsnps, numindivs, nignore) ;
if (poplistname != NULL)
{
ZALLOC(eglist, numindivs, char *) ;
numeg = loadlist(eglist, poplistname) ;
seteglist(indivmarkers, numindivs, poplistname);
}
else
{
setstatus(indivmarkers, numindivs, NULL) ;
ZALLOC(eglist, MAXPOPS, char *) ;
numeg = makeeglist(eglist, MAXPOPS, indivmarkers, numindivs) ;
}
for (i=0; i<numeg; i++)
{
/* printf("%3d %s\n",i, eglist[i]) ; */
}
nindiv=0 ;
for (i=0; i<numindivs; i++)
{
indx = indivmarkers[i] ;
if(indx -> affstatus == YES) ++nindiv ;
}
for (i=0; i<numsnps; i++)
{
cupt = snpmarkers[i] ;
chrom = cupt -> chrom ;
if ((noxdata) && (chrom == (numchrom+1))) cupt-> ignore = YES ;
if (chrom == 0) cupt -> ignore = YES ;
if (chrom > (numchrom+1)) cupt -> ignore = YES ;
}
for (i=0; i<numsnps; i++)
{
cupt = snpmarkers[i] ;
pos = nnint(cupt -> physpos) ;
if ((xchrom>0) && (cupt -> chrom != xchrom)) cupt -> ignore = YES ;
if ((xchrom > 0) && (pos < lopos)) cupt -> ignore = YES ;
if ((xchrom > 0) && (pos > hipos)) cupt -> ignore = YES ;
if (cupt -> ignore) continue ;
if (numvalidgtx(indivmarkers, cupt, YES) <= 1)
{
printf("nodata: %20s\n", cupt -> ID) ;
cupt -> ignore = YES ;
}
}
if (killr2) {
nkill = killhir2(snpmarkers, numsnps, numindivs, r2physlim, r2genlim, r2thresh) ;
if (nkill>0) printf("killhir2. number of snps killed: %d\n", nkill) ;
}
ZALLOC(vv, numindivs, int) ;
numvalidgtallind(vv, snpmarkers, numsnps, numindivs) ;
for (i=0; i<numindivs; ++i) {
if (vv[i] == 0) {
indx = indivmarkers[i] ;
indx -> ignore = YES ;
}
}
free(vv) ;
numsnps = rmsnps(snpmarkers, numsnps, NULL) ; // rid ignorable snps
if (missingmode)
{
setmiss(snpmarkers, numsnps) ;
fancynorm = NO ;
}
if (weightname != NULL)
{
weightmode = YES ;
getweights(weightname, snpmarkers, numsnps) ;
}
if (ldregress>0)
{
ZALLOC(ldvv, ldregress*numindivs, double) ;
ZALLOC(ldvv2, ldregress*numindivs, double) ;
ZALLOC(vv2, numindivs, double) ;
ZALLOC(ldmat, ldregress*ldregress, double) ;
ZALLOC(ldmat2, ldregress*ldregress, double) ;
setidmat(ldmat, ldregress) ;
vst(ldmat, ldmat, 1.0e-6, ldregress*ldregress) ;
}
ZALLOC(xindex, numindivs, int) ;
ZALLOC(xindlist, numindivs, Indiv *) ;
ZALLOC(xsnplist, numsnps, SNP *) ;
if (popsizelimit > 0)
{
setplimit(indivmarkers, numindivs, eglist, numeg, popsizelimit) ;
}
nrows = loadindx(xindlist, xindex, indivmarkers, numindivs) ;
ncols = loadsnpx(xsnplist, snpmarkers, numsnps, indivmarkers) ;
printf("number of samples used: %d number of snps used: %d\n", nrows, ncols) ;
/**
cupt = xsnplist[0] ;
for (j=0; j<nrows; ++j) {
k = xindex[j] ;
g = getgtypes(cupt, k) ;
indx = indivmarkers[k] ;
t = indxindex(eglist, numeg, indx -> egroup) ;
printf("yy1 %20s %20s %20s %d %d %d\n", cupt ->ID, indx -> ID, indx -> egroup, j, k, g) ;
}
printf("yya: ") ; printimat(xindex, 1, nrows) ;
printf("zzindxa: %s\n", indivmarkers[230] -> egroup) ;
*/
/* printf("## nrows: %d ncols %d\n", nrows, ncols) ; */
ZALLOC(xmean, ncols, double) ;
ZALLOC(xfancy, ncols, double) ;
ZALLOC(XTX, nrows*nrows, double) ;
ZALLOC(evecs, nrows*nrows, double) ;
ZALLOC(tvecs, nrows*nrows, double) ;
ZALLOC(lambda, nrows, double) ;
ZALLOC(cc, nrows, double) ;
ZALLOC(ww, nrows, double) ;
ZALLOC(badlist, nrows, int) ;
blocksize = MIN(blocksize, ncols) ;
ZALLOC(tblock, nrows*blocksize, double) ;
// xfancy is multiplier for column xmean is mean to take off
// badlist is list of rows to delete (outlier removal)
numoutiter = 1 ;
if (numoutliter>=1)
{
numoutiter = numoutliter+1 ;
ZALLOC(outinfo, nrows, OUTLINFO *) ;
for (k=0; k<nrows; k++)
{
ZALLOC(outinfo[k], 1, OUTLINFO) ;
}
/* fprintf(outlfile, "##%18s %4s %6s %9s\n", "ID", "iter","eigvec", "score") ; */
}
for (outliter = 1; outliter <= numoutiter ; ++outliter) {
if (fstonly) {
setidmat(XTX, nrows) ;
vclear(lambda, 1.0, nrows) ;
break ;
}
if (outliter>1) {
ncols = loadsnpx(xsnplist, snpmarkers, numsnps, indivmarkers) ;
}
vzero(XTX, nrows*nrows) ;
vzero(tblock, nrows*blocksize) ;
xblock = 0 ;
vzero(xmean, ncols) ;
vclear(xfancy, 1.0, ncols) ;
for (i=0; i<ncols; i++)
{
cupt = xsnplist[i] ;
chrom = cupt -> chrom ;
getcolxz(cc, cupt, xindex, nrows, i, xmean, xfancy, &n0, &n1) ;
t = MIN(n0, n1) ;
if (t <= minallelecnt) {
cupt -> ignore = YES ;
vzero(cc, nrows) ;
}
if (weightmode)
{
vst(cc, cc, xsnplist[i] -> weight, nrows) ;
}
if (ldregress>0)
{
numclear = 0 ;
for (k=1; k<= ldregress; ++k)
{
j = i-k ;
if (j<0)
{
numclear = ldregress-k+1 ;
break ;
}
cupt2 = xsnplist[j] ;
if (cupt2 -> chrom != chrom) gdis = ldlimit + 1.0 ;
else gdis = cupt -> genpos - cupt2 -> genpos ;
if (gdis>=ldlimit)
{
numclear = ldregress-k+1 ;
break ;
}
}
if (numclear>0) clearld(ldmat, ldvv, ldregress, nrows, numclear) ;
ldreg(ldmat, ldmat2, cc, vv2, ldvv, ldvv2, ldregress, nrows) ;
copyarr(ldmat2, ldmat, ldregress*ldregress) ;
copyarr(vv2, cc, nrows) ;
copyarr(ldvv2, ldvv, ldregress*nrows) ;
}
copyarr(cc, tblock+xblock*nrows, nrows) ;
++xblock ;
/** this is the key code to parallelize */
if (xblock==blocksize)
{
domult(tvecs, tblock, xblock, nrows) ;
vvp(XTX, XTX, tvecs, nrows*nrows) ;
xblock = 0 ;
vzero(tblock, nrows*blocksize) ;
}
}
if (xblock>0)
{
domult(tvecs, tblock, xblock, nrows) ;
vvp(XTX, XTX, tvecs, nrows*nrows) ;
}
symit(XTX, nrows) ;
/**
a = 0; b=0 ;
printf("zz1 %12.6f ", XTX[a*nrows+b]) ;
a = nrows-1; b=nrows-1 ;
printf(" %12.6f %15.9g\n", XTX[a*nrows+b], asum(XTX, nrows*nrows)) ;
*/
if (verbose)
{
printdiag(XTX, nrows) ;
}
y = trace(XTX, nrows) / (double) (nrows-1) ;
if (isnan(y)) fatalx("bad XTX matrix\n") ;
/* printf("trace: %9.3f\n", y) ; */
if (y<=0.0) fatalx("XTX has zero trace (perhaps no data)\n") ;
vst(XTX, XTX, 1.0/y, nrows * nrows) ;
/// mean eigenvalue is 1
eigvecs(XTX, lambda, evecs, nrows) ;
// eigenvalues are in decreasing order
if (outliter > numoutliter) break ;
// last pass skips outliers
numoutleigs = MIN(numoutleigs, nrows-1) ;
nbad = ridoutlier(evecs, nrows, numoutleigs, outlthresh, badlist, outinfo) ;
if (nbad == 0) break ;
for (i=0; i<nbad; i++)
{
j = badlist[i] ;
indx = xindlist[j] ;
outpt = outinfo[j] ;
fprintf(outlfile, "REMOVED outlier %s iter %d evec %d sigmage %.3f\n", indx -> ID, outliter, outpt -> vecno, outpt -> score) ;
indx -> ignore = YES ;
}
nrows = loadindx(xindlist, xindex, indivmarkers, numindivs) ;
printf("number of samples after outlier removal: %d\n", nrows) ;
}
if (outliername != NULL) fclose(outlfile) ;
m = numgtz(lambda, nrows) ;
/* printf("matrix rank: %d\n", m) ; */
if (m==0) fatalx("no data\n") ;
/** smartrel code */
for (i=0; i<numeigs; i++) {
y = sqrt(lambda[i]) ;
vst(ww, evecs+i*nrows, y, nrows) ;
subouter(XTX, ww, nrows) ;
}
free(tvecs) ;
n = 0 ;
ZALLOC(vecind, nrows*nrows/2, int) ;
for (i=0; i<nrows; i++) {
for (j=i+1; j<nrows; j++) {
k = i*nrows + j ;
y1 = XTX[i*nrows+i] ;
y2 = XTX[j*nrows+j] ;
y = XTX[k]/sqrt(y1*y2) ;
y += 1/(double)(nrows-1);
if (y<relthresh) continue ;
vecind[n] = k ;
evecs[n] = -y ;
++n ;
}
}
free(XTX) ;
if (n==0) {
printf("## nothing above relthresh!\n") ;
printf("##end of smartrel run\n") ;
return 0 ;
}
ZALLOC(idperm, n, int) ;
sortit(evecs, idperm, n) ;
for (i=0; i<n; i++) {
j = idperm[i] ;
k = vecind[j] ;
a = k/nrows ;
b = k%nrows ;
printf("rel: %20s ", xindlist[a] ->ID) ;
printf("%20s ", xindlist[b] ->ID) ;
printf(" %9.3f", -evecs[i]) ;
printnl() ;
}
printf("##end of smartrel run\n") ;
return 0 ;
}
void
continue_problem (Comm_Ex *cx, /* array of communications structures */
Exo_DB *exo, /* ptr to the finite element mesh database */
Dpi *dpi) /* distributed processing information */
{
int *ija=NULL; /* column pointer array */
double *a=NULL; /* nonzero array */
double *a_old=NULL; /* nonzero array */
double *x=NULL; /* solution vector */
int iAC; /* COUNTER */
double *x_AC = NULL; /* SOLUTION VECTOR OF EXTRA UNKNOWNS */
double *x_AC_old=NULL; /* old SOLUTION VECTOR OF EXTRA UNKNOWNS */
double *x_AC_dot=NULL;
int *ija_attic=NULL; /* storage for external dofs */
int eb_indx, ev_indx;
/*
* variables for path traversal
*/
double *x_old=NULL; /* old solution vector */
double *x_older=NULL; /* older solution vector */
double *x_oldest=NULL; /* oldest solution vector saved */
double *xdot=NULL; /* current path derivative of soln */
double *xdot_old=NULL;
double *x_update=NULL;
double *x_sens=NULL; /* solution sensitivity */
double *x_sens_temp=NULL; /* MMH thinks we need another one, so
* that when the solution is updated
* on a failure, it doesn't use the
* last computed x_sens b/c that might
* be crappy. We should use the last
* known good one... I haven't done
* the same thing with x_sens_p.
*/
double **x_sens_p=NULL; /* solution sensitivity for parameters */
int num_pvector=0; /* number of solution sensitivity vectors */
#ifdef COUPLED_FILL
struct Aztec_Linear_Solver_System *ams[NUM_ALSS]={NULL};
#else /* COUPLED_FILL */
struct Aztec_Linear_Solver_System *ams[NUM_ALSS]={NULL, NULL};
#endif /* COUPLED_FILL */
/* sl_util_structs.h */
double *resid_vector=NULL; /* residual */
double *resid_vector_sens=NULL;/* residual sensitivity */
double *scale=NULL; /* scale vector for modified newton */
int *node_to_fill = NULL;
int n; /* total number of path steps attempted */
int ni; /* total number of nonlinear solves */
int nt; /* total number of successful path steps */
int path_step_reform; /* counter for jacobian reformation stride */
int converged; /* success or failure of Newton iteration */
int success_ds; /* success or failure of path step */
int i, nprint=0, num_total_nodes;
int numProcUnknowns;
int const_delta_s, step_print;
double path_print, i_print;
double path, /* Current value (should have solution here) */
path1; /* New value (would like to get solution here) */
double delta_s, delta_s_new, delta_s_old, delta_s_older, delta_s_oldest;
double delta_t;
double theta=0.0;
double damp;
double eps;
double lambda, lambdaEnd;
double timeValueRead = 0.0;
/*
* ALC management variables
*/
int aldALC, /* direction of continuation, == -1 =>
beginning value is greater than ending value. */
alqALC; /* is -1 when we're on our last step. */
/*
* Other local variables
*/
int error, err, is_steady_state, inewton;
int *gindex = NULL, gsize;
int *p_gsize=NULL;
double *gvec=NULL;
double ***gvec_elem=NULL;
double err_dbl;
FILE *cl_aux=NULL, *file=NULL;
struct Results_Description *rd=NULL;
int tnv; /* total number of nodal variables and kinds */
int tev; /* total number of elem variables and kinds */
int tnv_post; /* total number of nodal variables and kinds
for post processing */
int tev_post; /* total number of elem variables and kinds
for post processing */
int iUC; /* User-defined continuation condition index */
int max_unk_elem, one, three; /* variables used as mf_setup arguments*/
unsigned int matrix_systems_mask;
double evol_local=0.0;
#ifdef PARALLEL
double evol_global=0.0;
#endif
static const char yo[]="continue_problem";
/*
* BEGIN EXECUTION
*/
#ifdef DEBUG
fprintf(stderr, "%s() begins...\n", yo);
#endif
is_steady_state = TRUE;
p_gsize = &gsize;
/*
* set aside space for gather global vectors to print to exoII file
* note: this is temporary
*
* For 2D prototype problem: allocate space for T, dx, dy arrays
*/
if( strlen(Soln_OutFile) )
{
file = fopen(Soln_OutFile, "w");
if (file == NULL) {
DPRINTF(stderr, "%s: opening soln file for writing\n", yo);
EH(-1, "\t");
}
}
#ifdef PARALLEL
check_parallel_error("Soln output file error");
#endif
/*
* Some preliminaries to help setup EXODUS II database output.
*/
#ifdef DEBUG
fprintf(stderr, "cnt_nodal_vars() begins...\n");
#endif
/*
* tnv_post is calculated in load_nodal_tkn
* tev_post is calculated in load_elem_tkn
*/
tnv = cnt_nodal_vars();
tev = cnt_elem_vars();
#ifdef DEBUG
fprintf(stderr, "Found %d total primitive nodal variables to output.\n", tnv);
fprintf(stderr, "Found %d total primitive elem variables to output.\n", tev);
#endif
if (tnv < 0)
{
DPRINTF(stderr, "%s:\tbad tnv.\n", yo);
EH(-1, "\t");
}
rd = (struct Results_Description *)
smalloc(sizeof(struct Results_Description));
if (rd == NULL)
EH(-1, "Could not grab Results Description.");
(void) memset((void *) rd, 0, sizeof(struct Results_Description));
rd->nev = 0; /* number element variables in results */
rd->ngv = 0; /* number global variables in results */
rd->nhv = 0; /* number history variables in results */
rd->ngv = 5; /* number global variables in results
see load_global_var_info for names*/
error = load_global_var_info(rd, 0, "CONV");
error = load_global_var_info(rd, 1, "NEWT_IT");
error = load_global_var_info(rd, 2, "MAX_IT");
error = load_global_var_info(rd, 3, "CONVRATE");
error = load_global_var_info(rd, 4, "MESH_VOLUME");
/* load nodal types, kinds, names */
error = load_nodal_tkn(rd,
&tnv,
&tnv_post);
if (error)
{
DPRINTF(stderr, "%s: problem with load_nodal_tkn()\n", yo);
EH(-1,"\t");
}
/* load elem types, names */
error = load_elem_tkn(rd,
exo,
tev,
&tev_post);
if (error)
{
DPRINTF(stderr, "%s: problem with load_elem_tkn()\n", yo);
EH(-1,"\t");
}
#ifdef PARALLEL
check_parallel_error("Results file error");
#endif
/*
* Write out the names of the nodal variables that we will be sending to
* the EXODUS II output file later.
*/
#ifdef DEBUG
fprintf(stderr, "wr_result_prelim() starts...\n", tnv);
#endif
gvec_elem = (double ***) smalloc ( (exo->num_elem_blocks)*sizeof(double **));
for (i = 0; i < exo->num_elem_blocks; i++)
gvec_elem[i] = (double **) smalloc ( (tev + tev_post)*sizeof(double *));
wr_result_prelim_exo(rd,
exo,
ExoFileOut,
gvec_elem );
#ifdef DEBUG
fprintf(stderr, "P_%d: wr_result_prelim_exo() ends...\n", ProcID, tnv);
#endif
/*
* This gvec workhorse transports output variables as nodal based vectors
* that are gather from the solution vector. Note: it is NOT a global
* vector at all and only carries this processor's nodal variables to
* the exodus database.
*/
asdv(&gvec, Num_Node);
/*
* Allocate space and manipulate for all the nodes that this processor
* is aware of...
*/
num_total_nodes = dpi->num_universe_nodes;
numProcUnknowns = NumUnknowns + NumExtUnknowns;
/* allocate memory for Volume Constraint Jacobian */
if ( nAC > 0)
for(iAC=0;iAC<nAC;iAC++)
augc[iAC].d_evol_dx = (double*) malloc(numProcUnknowns*sizeof(double));
asdv(&resid_vector, numProcUnknowns);
asdv(&resid_vector_sens, numProcUnknowns);
asdv(&scale, numProcUnknowns);
for (i = 0; i < NUM_ALSS; i++)
{
ams[i] = alloc_struct_1(struct Aztec_Linear_Solver_System, 1);
}
#ifdef MPI
AZ_set_proc_config( ams[0]->proc_config, MPI_COMM_WORLD );
#ifndef COUPLED_FILL
if( Explicit_Fill ) AZ_set_proc_config( ams[1]->proc_config, MPI_COMM_WORLD );
#endif /* not COUPLED_FILL */
#else /* MPI */
AZ_set_proc_config( ams[0]->proc_config, 0 );
#ifndef COUPLED_FILL
if( Explicit_Fill ) AZ_set_proc_config( ams[1]->proc_config, 0 );
#endif /* not COUPLED_FILL */
#endif /* MPI */
/*
* allocate space for and initialize solution arrays
*/
asdv(&x, numProcUnknowns);
asdv(&x_old, numProcUnknowns);
asdv(&x_older, numProcUnknowns);
asdv(&x_oldest, numProcUnknowns);
asdv(&xdot, numProcUnknowns);
asdv(&xdot_old, numProcUnknowns);
asdv(&x_update, numProcUnknowns);
asdv(&x_sens, numProcUnknowns);
asdv(&x_sens_temp, numProcUnknowns);
/*
* Initialize solid inertia flag
*/
set_solid_inertia();
/*
* FRIENDLY COMMAND LINE EQUIV
*/
if( ProcID == 0 )
{
cl_aux = fopen("goma-cl.txt", "w+");
fprintf(cl_aux, "goma -a -i input ");
fprintf(cl_aux, "-cb %10.6e ", cont->BegParameterValue);
fprintf(cl_aux, "-ce %10.6e ", cont->EndParameterValue);
fprintf(cl_aux, "-cd %10.6e ", cont->Delta_s0);
fprintf(cl_aux, "-cn %d ", cont->MaxPathSteps);
fprintf(cl_aux, "-cmin %10.6e ", cont->Delta_s_min);
fprintf(cl_aux, "-cmax %10.6e ", cont->Delta_s_max);
fprintf(cl_aux, "-cm %d ", Continuation);
fprintf(cl_aux, "-ct %d ", cont->upType);
switch (cont->upType)
{
case 1: /* BC TYPE */
fprintf(cl_aux, "-c_bc %d ", cont->upBCID);
fprintf(cl_aux, "-c_df %d ", cont->upDFID);
break;
case 2: /* MAT TYPE */
fprintf(cl_aux, "-c_mn %d ", cont->upMTID+1);
fprintf(cl_aux, "-c_mp %d ", cont->upMPID);
break;
case 3: /* AC TYPE */
fprintf(cl_aux, "-c_ac %d ", cont->upBCID);
fprintf(cl_aux, "-c_df %d ", cont->upDFID);
break;
case 4: /* USER MAT TYPE */
fprintf(cl_aux, "-c_mn %d ", cont->upMTID+1);
fprintf(cl_aux, "-c_mp %d ", cont->upMPID);
fprintf(cl_aux, "-c_md %d ", cont->upMDID);
break;
case 5: /* USER-DEFINED FUNCTION TYPE */
/* NOTE: This is not available via the command line! */
break;
case 6: /* ANGULAR CONTINUATION TYPE */
/* NOTE: This requires LOCA and is not available via the command line! */
EH(-1, "Angular continuation is available only in LOCA!");
break;
default:
fprintf(stderr, "%s: Bad cont->upType, %d\n", yo, cont->upType);
EH(-1,"Bad cont->upType");
break; /* duh */
}
fprintf(cl_aux, "\n");
fclose(cl_aux);
}
#ifdef PARALLEL
check_parallel_error("Continuation setup error");
#endif
/*
* FIRST ORDER CONTINUATION
*/
lambda = cont->BegParameterValue;
lambdaEnd = cont->EndParameterValue;
if (lambdaEnd > lambda)
aldALC = +1;
else
aldALC = -1;
delta_s_new = 0.0;
Delta_s0 = cont->Delta_s0;
Delta_s_min = cont->Delta_s_min;
Delta_s_max = cont->Delta_s_max;
MaxPathSteps = cont->MaxPathSteps;
PathMax = cont->PathMax;
eps = cont->eps;
if (Delta_s0 < 0.0 )
{
Delta_s0 = -Delta_s0;
const_delta_s = 1;
}
else
const_delta_s = 0;
damp = 1.0;
path = path1 = lambda;
if (Debug_Flag && ProcID == 0)
{
fprintf(stderr,"MaxPathSteps: %d \tlambdaEnd: %f\n", MaxPathSteps, lambdaEnd);
fprintf(stderr,"continuation in progress\n");
}
nprint = 0;
if (Delta_s0 > Delta_s_max)
Delta_s0 = Delta_s_max;
delta_s = delta_s_old = delta_s_older = Delta_s0;
delta_t = 0.0;
tran->delta_t = 0.0; /*for Newmark-Beta terms in Lagrangian Solid*/
/* Call prefront (or mf_setup) if necessary */
if (Linear_Solver == FRONT)
{
/* Also got to define these because it wants pointers to these numbers */
max_unk_elem = (MAX_PROB_VAR + MAX_CONC)*MDE;
one = 1;
three = 3;
/* NOTE: We need a overall flag in the vn_glob struct that tells whether FULL_DG
is on anywhere in domain. This assumes only one material. See sl_front_setup for test.
that test needs to be in the input parser. */
if(vn_glob[0]->dg_J_model == FULL_DG)
max_unk_elem = (MAX_PROB_VAR + MAX_CONC)*MDE + 4*vn_glob[0]->modes*4*MDE;
#ifdef PARALLEL
if (Num_Proc > 1) EH(-1, "Whoa. No front allowed with nproc>1");
check_parallel_error("Front solver not allowed with nprocs>1");
#endif
#ifdef HAVE_FRONT
err = mf_setup(&exo->num_elems,
&NumUnknowns,
&max_unk_elem,
&three,
&one,
exo->elem_order_map,
fss->el_proc_assign,
fss->level,
fss->nopdof,
fss->ncn,
fss->constraint,
front_scratch_directory,
&fss->ntra);
EH(err,"problems in frontal setup ");
#else
EH(-1,"Don't have frontal solver compiled and linked in");
#endif
}
/*
* if computing parameter sensitivities, allocate space for solution
* sensitivity vectors
*/
for(i=0;i<nn_post_fluxes_sens;i++)
{
num_pvector=MAX(num_pvector,pp_fluxes_sens[i]->vector_id);
}
for(i=0;i<nn_post_data_sens;i++)
{
num_pvector=MAX(num_pvector,pp_data_sens[i]->vector_id);
}
if((nn_post_fluxes_sens + nn_post_data_sens) > 0)
{
num_pvector++;
num_pvector = MAX(num_pvector,2);
x_sens_p = Dmatrix_birth(num_pvector,numProcUnknowns);
}
else
x_sens_p = NULL;
if (nAC > 0)
{
asdv(&x_AC, nAC);
asdv(&x_AC_old, nAC);
asdv(&x_AC_dot, nAC);
}
/*
* ADJUST NATURAL PARAMETER
*/
update_parameterC(0, path1, x, xdot, x_AC, delta_s, cx, exo, dpi);
/* Allocate sparse matrix */
if( strcmp( Matrix_Format, "msr" ) == 0)
{
log_msg("alloc_MSR_sparse_arrays...");
alloc_MSR_sparse_arrays(&ija,
&a,
&a_old,
0,
node_to_fill,
exo,
dpi);
/*
* An attic to store external dofs column names is needed when
* running in parallel.
*/
alloc_extern_ija_buffer(num_universe_dofs,
num_internal_dofs+num_boundary_dofs,
ija, &ija_attic);
/*
* Any necessary one time initialization of the linear
* solver package (Aztec).
*/
ams[JAC]->bindx = ija;
ams[JAC]->val = a;
ams[JAC]->belfry = ija_attic;
ams[JAC]->val_old = a_old;
/*
* These point to nowhere since we're using MSR instead of VBR
* format.
*/
ams[JAC]->indx = NULL;
ams[JAC]->bpntr = NULL;
ams[JAC]->rpntr = NULL;
ams[JAC]->cpntr = NULL;
ams[JAC]->npn = dpi->num_internal_nodes + dpi->num_boundary_nodes;
ams[JAC]->npn_plus = dpi->num_internal_nodes + dpi->num_boundary_nodes + dpi->num_external_nodes;
ams[JAC]->npu = num_internal_dofs+num_boundary_dofs;
ams[JAC]->npu_plus = num_universe_dofs;
ams[JAC]->nnz = ija[num_internal_dofs+num_boundary_dofs] - 1;
ams[JAC]->nnz_plus = ija[num_universe_dofs];
}
else if( strcmp( Matrix_Format, "vbr" ) == 0)
{
log_msg("alloc_VBR_sparse_arrays...");
alloc_VBR_sparse_arrays (ams[JAC],
exo,
dpi);
ija_attic = NULL;
ams[JAC]->belfry = ija_attic;
a = ams[JAC]->val;
if( !save_old_A ) a_old = ams[JAC]->val_old = NULL;
}
else if ( strcmp( Matrix_Format, "front") == 0 )
{
/* Don't allocate any sparse matrix space when using front */
ams[JAC]->bindx = NULL;
ams[JAC]->val = NULL;
ams[JAC]->belfry = NULL;
ams[JAC]->val_old = NULL;
ams[JAC]->indx = NULL;
ams[JAC]->bpntr = NULL;
ams[JAC]->rpntr = NULL;
ams[JAC]->cpntr = NULL;
}
else
EH(-1,"Attempted to allocate unknown sparse matrix format");
init_vec(x, cx, exo, dpi, x_AC, nAC, &timeValueRead);
/* if read ACs, update data floats */
if (nAC > 0)
if(augc[0].iread == 1)
{
for(iAC=0 ; iAC<nAC ; iAC++)
{ update_parameterAC(iAC, x, xdot, x_AC, cx, exo, dpi);}
}
vzero(numProcUnknowns, &x_sens[0]);
vzero(numProcUnknowns, &x_sens_temp[0]);
/*
* set boundary conditions on the initial conditions
*/
nullify_dirichlet_bcs();
find_and_set_Dirichlet(x, xdot, exo, dpi);
exchange_dof(cx, dpi, x);
dcopy1(numProcUnknowns,x,x_old);
dcopy1(numProcUnknowns,x_old,x_older);
dcopy1(numProcUnknowns,x_older,x_oldest);
if(nAC > 0)
dcopy1(nAC,x_AC, x_AC_old);
/*
* initialize the counters for when to print out data
*/
path_print = path1;
step_print = 1;
matrix_systems_mask = 1;
log_msg("sl_init()...");
sl_init(matrix_systems_mask, ams, exo, dpi, cx);
/*
* Make sure the solver was properly initialized on all processors.
*/
#ifdef PARALLEL
check_parallel_error("Solver initialization problems");
#endif
ams[JAC]->options[AZ_keep_info] = 1;
/*
* set the number of successful path steps to zero
*/
nt = 0;
/*
* LOOP THROUGH PARAMETER UNTIL MAX NUMBER
* OF STEPS SURPASSED
*/
for(n = 0; n < MaxPathSteps; n++)
{
alqALC = 1;
switch (aldALC)
{
case -1: /* REDUCING PARAMETER DIRECTION */
if (path1 <= lambdaEnd)
{
DPRINTF(stderr,"\n\t ******** LAST PATH STEP!\n");
alqALC = -1;
path1 = lambdaEnd;
delta_s = path-path1;
}
break;
case +1: /* RISING PARAMETER DIRECTION */
if (path1 >= lambdaEnd)
{
DPRINTF(stderr,"\n\t ******** LAST PATH STEP!\n");
alqALC = -1;
path1 = lambdaEnd;
delta_s = path1-path;
}
break;
default:
DPRINTF(stderr, "%s: Bad aldALC, %d\n", yo, aldALC);
EH(-1,"\t");
break; /* duh */
}
#ifdef PARALLEL
check_parallel_error("Bad aldALC");
#endif
/*
* ADJUST NATURAL PARAMETER
*/
update_parameterC(0, path1, x, xdot, x_AC, delta_s,
cx, exo, dpi);
/*
* IF STEP CHANGED, REDO FIRST ORDER PREDICTION
*/
if(alqALC == -1)
{
dcopy1(NumUnknowns,x_old,x);
switch (Continuation)
{
case ALC_ZEROTH:
break;
case ALC_FIRST:
switch (aldALC)
{
case -1:
v1add(NumUnknowns, &x[0], -delta_s, &x_sens[0]);
break;
case +1:
v1add(NumUnknowns, &x[0], +delta_s, &x_sens[0]);
break;
default:
DPRINTF(stderr, "%s: Bad aldALC, %d\n", yo, aldALC);
EH(-1,"\t");
break; /* duh */
}
break;
default:
DPRINTF(stderr, "%s: Bad Continuation, %d\n", yo, Continuation);
EH(-1,"\t");
break; /* duh */
}
}
#ifdef PARALLEL
check_parallel_error("Bad Continuation");
#endif
find_and_set_Dirichlet (x, xdot, exo, dpi);
exchange_dof(cx, dpi, x);
if (ProcID == 0)
{
fprintf(stderr, "\n\t----------------------------------");
switch (Continuation)
{
case ALC_ZEROTH:
DPRINTF(stderr, "\n\tZero Order Continuation:");
break;
case ALC_FIRST:
DPRINTF(stderr, "\n\tFirst Order Continuation:");
break;
default:
DPRINTF(stderr, "%s: Bad Continuation, %d\n", yo, Continuation);
EH(-1,"\t");
break; /* duh */
}
DPRINTF(stderr, "\n\tStep number: %4d of %4d (max)", n+1, MaxPathSteps);
DPRINTF(stderr, "\n\tAttempting solution at:");
switch (cont->upType)
{
case 1: /* BC */
case 3: /* AC */
DPRINTF(stderr, "\n\tBCID=%3d DFID=%5d", cont->upBCID, cont->upDFID);
break;
case 2: /* MT */
DPRINTF(stderr, "\n\tMTID=%3d MPID=%5d", cont->upMTID, cont->upMPID);
break;
case 4: /* UM */
DPRINTF(stderr, "\n\tMTID=%3d MPID=%5d MDID=%3d", cont->upMTID, cont->upMPID, cont->upMDID);
break;
/* This case requires an inner switch block */
case 5: /* UF */
for (iUC=0; iUC<nUC; iUC++)
{
switch (cpuc[iUC].Type)
{
case 1: /* BC */
case 3: /* AC */
DPRINTF(stderr, "\n\tBCID=%3d DFID=%5d",
cpuc[iUC].BCID, cpuc[iUC].DFID);
break;
case 2: /* MT */
DPRINTF(stderr, "\n\tMTID=%3d MPID=%5d",
cpuc[iUC].MTID, cpuc[iUC].MPID);
break;
case 4: /* UM */
DPRINTF(stderr, "\n\tMTID=%3d MPID=%5d MDID=%3d",
cpuc[iUC].MTID, cpuc[iUC].MPID, cpuc[iUC].MDID);
break;
default:
DPRINTF(stderr, "%s: Bad user continuation type, %d\n",
yo, cont->upType);
EH(-1,"\t");
break;
}
DPRINTF(stderr, " Parameter= % 10.6e delta_s= %10.6e",
cpuc[iUC].value, (cpuc[iUC].value-cpuc[iUC].old_value) );
}
break;
default:
DPRINTF(stderr, "%s: Bad cont->upType, %d\n", yo, cont->upType);
EH(-1,"\t");
break; /* duh */
}
if (cont->upType != 5)
{
DPRINTF(stderr, " Parameter= % 10.6e delta_s= %10.6e", path1, delta_s);
}
}
#ifdef PARALLEL
check_parallel_error("Bad cont->upType");
#endif
ni = 0;
do {
#ifdef DEBUG
DPRINTF(stderr, "%s: starting solve_nonlinear_problem\n", yo);
#endif
err = solve_nonlinear_problem(ams[JAC],
x,
delta_t,
theta,
x_old,
x_older,
xdot,
xdot_old,
resid_vector,
x_update,
scale,
&converged,
&nprint,
tev,
tev_post,
NULL,
rd,
gindex,
p_gsize,
gvec,
gvec_elem,
path1,
exo,
dpi,
cx,
0,
&path_step_reform,
is_steady_state,
x_AC,
x_AC_dot,
path1,
resid_vector_sens,
x_sens_temp,
x_sens_p,
NULL);
#ifdef DEBUG
fprintf(stderr, "%s: returned from solve_nonlinear_problem\n", yo);
#endif
if (err == -1)
converged = 0;
inewton = err;
if (converged)
{
if (Write_Intermediate_Solutions == 0) {
#ifdef DEBUG
DPRINTF(stderr, "%s: write_solution call WIS\n", yo);
#endif
write_solution(ExoFileOut, resid_vector, x, x_sens_p,
x_old, xdot, xdot_old, tev, tev_post, NULL, rd,
gindex, p_gsize, gvec, gvec_elem, &nprint,
delta_s, theta, path1, NULL, exo, dpi);
#ifdef DEBUG
fprintf(stderr, "%s: write_solution end call WIS\n", yo);
#endif
}
#ifdef PARALLEL
check_parallel_error("Error writing exodusII file");
#endif
/*
* PRINT OUT VALUES OF EXTRA UNKNOWNS
* FROM AUGMENTING CONDITIONS
*/
if (nAC > 0)
{
DPRINTF(stderr, "\n------------------------------\n");
DPRINTF(stderr, "Augmenting Conditions: %4d\n", nAC);
DPRINTF(stderr, "Number of extra unknowns: %4d\n\n", nAC);
for (iAC = 0; iAC < nAC; iAC++)
{
if (augc[iAC].Type == AC_USERBC)
{
DPRINTF(stderr, "\tBC[%4d] DF[%4d] = %10.6e\n",
augc[iAC].BCID, augc[iAC].DFID, x_AC[iAC]);
}
else if (augc[iAC].Type == AC_USERMAT ||
augc[iAC].Type == AC_FLUX_MAT )
{
DPRINTF(stderr, "\tMT[%4d] MP[%4d] = %10.6e\n",
augc[iAC].MTID, augc[iAC].MPID, x_AC[iAC]);
}
else if(augc[iAC].Type == AC_VOLUME)
{
evol_local = augc[iAC].evol;
#ifdef PARALLEL
if( Num_Proc > 1 ) {
MPI_Allreduce( &evol_local, &evol_global, 1,
MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD);
}
evol_local = evol_global;
#endif
DPRINTF(stderr, "\tMT[%4d] VC[%4d]=%10.6e Param=%10.6e\n",
augc[iAC].MTID, augc[iAC].VOLID, evol_local,
x_AC[iAC]);
}
else if(augc[iAC].Type == AC_POSITION)
{
evol_local = augc[iAC].evol;
#ifdef PARALLEL
if( Num_Proc > 1 ) {
MPI_Allreduce( &evol_local, &evol_global, 1,
MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD);
}
evol_local = evol_global;
#endif
DPRINTF(stderr, "\tMT[%4d] XY[%4d]=%10.6e Param=%10.6e\n",
augc[iAC].MTID, augc[iAC].VOLID, evol_local,
x_AC[iAC]);
}
else if(augc[iAC].Type == AC_FLUX)
{
DPRINTF(stderr, "\tBC[%4d] DF[%4d]=%10.6e\n",
augc[iAC].BCID, augc[iAC].DFID, x_AC[iAC]);
}
}
}
/*
* INTEGRATE FLUXES, FORCES
*/
for (i = 0; i < nn_post_fluxes; i++)
err_dbl = evaluate_flux (exo, dpi,
pp_fluxes[i]->ss_id,
pp_fluxes[i]->flux_type ,
pp_fluxes[i]->flux_type_name ,
pp_fluxes[i]->blk_id ,
pp_fluxes[i]->species_number,
pp_fluxes[i]->flux_filenm,
pp_fluxes[i]->profile_flag,
x,xdot,NULL, delta_s,path1,1);
/*
* COMPUTE FLUX, FORCE SENSITIVITIES
*/
for (i = 0; i < nn_post_fluxes_sens; i++)
err_dbl = evaluate_flux_sens (exo, dpi,
pp_fluxes_sens[i]->ss_id,
pp_fluxes_sens[i]->flux_type ,
pp_fluxes_sens[i]->flux_type_name ,
pp_fluxes_sens[i]->blk_id ,
pp_fluxes_sens[i]->species_number,
pp_fluxes_sens[i]->sens_type,
pp_fluxes_sens[i]->sens_id,
pp_fluxes_sens[i]->sens_flt,
pp_fluxes_sens[i]->sens_flt2,
pp_fluxes_sens[i]->vector_id,
pp_fluxes_sens[i]->flux_filenm,
pp_fluxes_sens[i]->profile_flag,
x,xdot,x_sens_p,delta_s,path1,1);
/*
* Compute global volumetric quantities
*/
for (i = 0; i < nn_volume; i++ ) {
evaluate_volume_integral(exo, dpi,
pp_volume[i]->volume_type,
pp_volume[i]->volume_name,
pp_volume[i]->blk_id,
pp_volume[i]->species_no,
pp_volume[i]->volume_fname,
pp_volume[i]->params,
NULL, x, xdot, delta_s,
path1, 1);
}
} /* end of if converged block */
/*
* INCREMENT COUNTER
*/
ni++;
/*
* DID IT CONVERGE ?
* IF NOT, REDUCE STEP SIZE AND TRY AGAIN
*/
if (!converged)
{
if (ni > 5)
{
puts(" ");
puts(" ************************************");
puts(" W: Did not converge in Newton steps.");
puts(" Find better initial guess. ");
puts(" ************************************");
/* This needs to have a return value of 0, indicating
* success, for the continuation script to not treat this
* as a failed command. */
exit(0);
}
/*
* ADJUST STEP SIZE
*/
DPRINTF(stderr, "\n\tFailed to converge:\n");
delta_s *= 0.5;
switch (aldALC)
{
case -1:
path1 = path - delta_s;
break;
case +1:
path1 = path + delta_s;
break;
default:
DPRINTF(stderr, "%s: Bad aldALC, %d\n", yo, aldALC);
EH(-1,"\t");
break; /* duh */
}
#ifdef PARALLEL
check_parallel_error("Bad aldALC");
#endif
/*
* RESET
*/
alqALC = 1; /* If necessary, don't call this the last step... */
DPRINTF(stderr, "\n\tDecreasing step-length to %10.6e.\n", delta_s);
if (delta_s < Delta_s_min)
{
puts("\n X: C step-length reduced below minimum.");
puts("\n Program terminated.\n");
/* This needs to have a return value of 0, indicating
* success, for the continuation script to not treat this
* as a failed command. */
exit(0);
}
#ifdef PARALLEL
check_parallel_error("\t");
#endif
/*
* ADJUST NATURAL PARAMETER
*/
dcopy1(numProcUnknowns, x_old, x);
update_parameterC(0, path1, x, xdot, x_AC, delta_s,
cx, exo, dpi);
/*
* GET ZERO OR FIRST ORDER PREDICTION
*/
switch (Continuation)
{
case ALC_ZEROTH:
break;
case ALC_FIRST:
switch (aldALC)
{
case -1:
v1add(numProcUnknowns, &x[0], -delta_s, &x_sens[0]);
break;
case +1:
v1add(numProcUnknowns, &x[0], +delta_s, &x_sens[0]);
break;
default:
DPRINTF(stderr, "%s: Bad aldALC, %d\n", yo, aldALC);
EH(-1,"\t");
break; /* duh */
}
break;
default:
DPRINTF(stderr, "%s: Bad Continuation, %d\n", yo, Continuation);
EH(-1,"\t");
break; /* duh */
}
#ifdef PARALLEL
check_parallel_error("Bad Continuation");
#endif
/* MMH: Needed to put this in, o/w it may find that the
* solution and residual HAPPEN to satisfy the convergence
* criterion for the next newton solve...
*/
find_and_set_Dirichlet(x, xdot, exo, dpi);
exchange_dof(cx, dpi, x);
/* Should be doing first order prediction on ACs
* but for now, just reset the AC variables
*/
if( nAC > 0)
{
dcopy1(nAC, x_AC_old, x_AC);
for(iAC=0 ; iAC<nAC ; iAC++)
{ update_parameterAC(iAC, x, xdot, x_AC, cx, exo, dpi);}
}
} /* end of !converged */
} while (converged == 0);
/*
* CONVERGED
*/
nt++;
if( Continuation == ALC_ZEROTH ) {
DPRINTF(stderr, "\n\tStep accepted, parameter = %10.6e\n", path1);
}
else {
DPRINTF(stderr, "\tStep accepted, parameter = %10.6e\n", path1);
}
/*
* check path step error, if too large do not enlarge path step
*/
if ((ni == 1) && (n != 0) && (!const_delta_s))
{
delta_s_new = path_step_control(num_total_nodes,
delta_s, delta_s_old,
x,
eps,
&success_ds,
cont->use_var_norm, inewton);
if (delta_s_new > Delta_s_max)
delta_s_new = Delta_s_max;
}
else
{
success_ds = 1;
delta_s_new = delta_s;
}
/*
* determine whether to print out the data or not
*/
i_print = 0;
if (nt == step_print)
{
i_print = 1;
step_print += cont->print_freq;
}
if (alqALC == -1)
i_print = 1;
if (i_print)
{
error = write_ascii_soln(x, resid_vector, numProcUnknowns,
x_AC, nAC, path1, file);
if (error) {
DPRINTF(stdout, "%s: error writing ASCII soln file\n", yo);
}
if (Write_Intermediate_Solutions == 0 ) {
write_solution(ExoFileOut, resid_vector, x, x_sens_p,
x_old, xdot, xdot_old, tev, tev_post, NULL,
rd, gindex, p_gsize, gvec, gvec_elem, &nprint,
delta_s, theta, path1, NULL, exo, dpi);
nprint++;
}
}
/*
* backup old solutions
* can use previous solutions for prediction one day
*/
dcopy1(numProcUnknowns,x_older,x_oldest);
dcopy1(numProcUnknowns,x_old,x_older);
dcopy1(numProcUnknowns, x, x_old);
dcopy1(numProcUnknowns, x_sens_temp, x_sens);
delta_s_oldest = delta_s_older;
delta_s_older = delta_s_old;
delta_s_old = delta_s;
delta_s = delta_s_new;
if( nAC > 0)
dcopy1(nAC, x_AC, x_AC_old);
/*
* INCREMENT/DECREMENT PARAMETER
*/
path = path1;
switch (aldALC)
{
case -1:
path1 = path - delta_s;
break;
case +1:
path1 = path + delta_s;
break;
default:
DPRINTF(stderr, "%s: Bad aldALC, %d\n", yo, aldALC);
EH(-1,"\t");
break; /* duh */
}
#ifdef PARALLEL
check_parallel_error("Bad aldALC");
#endif
/*
* ADJUST NATURAL PARAMETER
*/
update_parameterC(0, path1, x, xdot, x_AC, delta_s,
cx, exo, dpi);
/*
display_parameterC(path1, x, xdot, delta_s,
cx, exo, dpi);
*/
/*
* GET FIRST ORDER PREDICTION
*/
switch (Continuation)
{
case ALC_ZEROTH:
break;
case ALC_FIRST:
switch (aldALC)
{
case -1:
v1add(numProcUnknowns, &x[0], -delta_s, &x_sens[0]);
break;
case +1:
v1add(numProcUnknowns, &x[0], +delta_s, &x_sens[0]);
break;
default:
DPRINTF(stderr, "%s: Bad aldALC, %d\n", yo, aldALC);
EH(-1,"\t");
break; /* duh */
}
break;
}
#ifdef PARALLEL
check_parallel_error("Bad aldALC");
#endif
/*
* CHECK END CONTINUATION
*/
/*
if (alqALC == -1)
alqALC = 0;
else
alqALC = 1;
*/
if (alqALC == -1)
{
DPRINTF(stderr,"\n\n\t I will continue no more!\n\t No more continuation for you!\n");
goto free_and_clear;
}
} /* for(n = 0; n < MaxPathSteps; n++) */
if(n == MaxPathSteps &&
aldALC * (lambdaEnd - path) > 0)
{
DPRINTF(stderr, "\n\tFailed to reach end of hunt in maximum number of successful steps (%d).\n\tSorry.\n",
MaxPathSteps);
/*
EH(-1,"\t");
*/
}
#ifdef PARALLEL
check_parallel_error("Continuation error");
#endif
/*
* DONE CONTINUATION
*/
free_and_clear:
/*
* Transform the node point coordinates according to the
* displacements and write out all the results using the
* displaced coordinates. Set the displacement field to
* zero, too.
*/
if (Anneal_Mesh)
{
#ifdef DEBUG
fprintf(stderr, "%s: anneal_mesh()...\n", yo);
#endif
err = anneal_mesh(x, tev, tev_post, NULL, rd, path1, exo, dpi);
#ifdef DEBUG
fprintf(stderr, "%s: anneal_mesh()-done\n", yo);
#endif
EH(err, "anneal_mesh() bad return.");
}
#ifdef PARALLEL
check_parallel_error("Trouble annealing mesh");
#endif
/*
* Free a bunch of variables that aren't needed anymore
*/
safer_free((void **) &ROT_Types);
safer_free((void **) &node_to_fill);
safer_free( (void **) &resid_vector);
safer_free( (void **) &resid_vector_sens);
safer_free( (void **) &scale);
safer_free( (void **) &x);
if (nAC > 0)
{
safer_free( (void **) &x_AC);
safer_free( (void **) &x_AC_old);
safer_free( (void **) &x_AC_dot);
}
safer_free( (void **) &x_old);
safer_free( (void **) &x_older);
safer_free( (void **) &x_oldest);
safer_free( (void **) &xdot);
safer_free( (void **) &xdot_old);
safer_free( (void **) &x_update);
safer_free( (void **) &x_sens);
safer_free( (void **) &x_sens_temp);
if((nn_post_data_sens+nn_post_fluxes_sens) > 0)
Dmatrix_death(x_sens_p,num_pvector,numProcUnknowns);
for(i = 0; i < MAX_NUMBER_MATLS; i++) {
for(n = 0; n < MAX_MODES; n++) {
safer_free((void **) &(ve_glob[i][n]->gn));
safer_free((void **) &(ve_glob[i][n]));
}
safer_free((void **) &(vn_glob[i]));
}
sl_free(matrix_systems_mask, ams);
for (i = 0; i < NUM_ALSS; i++)
safer_free((void **) &(ams[i]));
safer_free( (void **) &gvec);
i = 0;
for ( eb_indx = 0; eb_indx < exo->num_elem_blocks; eb_indx++ )
{
for ( ev_indx = 0; ev_indx < rd->nev; ev_indx++ ) {
if (exo->elem_var_tab[i++] == 1) {
safer_free((void **) &(gvec_elem [eb_indx][ev_indx]));
}
}
safer_free((void **) &(gvec_elem [eb_indx]));
}
safer_free( (void **) &gvec_elem);
if (cpcc != NULL) safer_free( (void **) &cpcc);
safer_free( (void **) &rd);
safer_free( (void **) &Local_Offset);
safer_free( (void **) &Dolphin);
if (file != NULL) fclose(file);
return;
} /* END of routine continue_problem */
void dopop3out(char **fglist, SNP **xsnplist, int ncols, char *line, char *outpop)
{
Indiv **xindlist ;
Indiv *indx ;
int *xindex, *xtypes ;
int nrows ;
int t, k, i, trun ;
double f3score, f3scoresig ;
double f2score, f2scoresig, y, y1, y2, p, q ;
char *eglist[4] ;
int numeg = 4 ;
double ytop, ybot, yxbot ;
double ztop, zbot ;
int col ;
SNP *cupt ;
double zztop[6], yytop[6] ;
double u, s1, s2, atop, btop, alphabot, betabot, alphatop ;
double ya, yb, za, zb, yt ;
char obuff[1024], *sx ;
int nsnp = 0 ;
copystrings(fglist, eglist, 3) ;
eglist[3] = strdup(outpop) ;
ZALLOC(xindex, numindivs, int) ;
ZALLOC(xindlist, numindivs, Indiv *) ;
setstatusv(indivmarkers, numindivs, NULL, NO) ;
setstatuslist(indivmarkers, numindivs, eglist, numeg) ;
nrows = loadindx(xindlist, xindex, indivmarkers, numindivs) ;
if (nrows == 0) {
for (i=0; i<numeg; ++i) {
printf("zz %s\n", eglist[i]) ;
}
fatalx("fatal error (probably missing pop)\n") ;
}
ZALLOC(xtypes, nrows, int) ;
for (i=0; i<nrows; i++) {
indx = xindlist[i] ;
k = indxindex(eglist, numeg, indx -> egroup) ;
xtypes[i] = k ;
}
ztop = zbot = 0.0 ;
vzero(zztop, 6) ;
for (col=0; col<ncols; ++col) {
cupt = xsnplist[col] ;
if (cupt -> ignore) continue ;
loadaa(cupt, xindex, xtypes, nrows, numeg) ;
f3scz(&ytop, &ybot, cupt, indivmarkers, xindex, xtypes, nrows, 2, 0, 1) ;
if (isnan(ytop)) fatalx("zznan\n") ;
if (ybot < -0.5) continue ;
f3scz(&yytop[0], &yxbot, cupt, indivmarkers, xindex, xtypes, nrows, 3, 0, 1) ; if (yxbot < -0.5) continue ;
f3scz(&yytop[1], &yxbot, cupt, indivmarkers, xindex, xtypes, nrows, 3, 0, 2) ; if (yxbot < -0.5) continue ;
f3scz(&yytop[2], &yxbot, cupt, indivmarkers, xindex, xtypes, nrows, 3, 1, 2) ; if (yxbot < -0.5) continue ;
f2scz(&yytop[3], &yxbot, cupt, indivmarkers, xindex, xtypes, nrows, 3, 0, 3) ; if (yxbot < -0.5) continue ;
f2scz(&yytop[4], &yxbot, cupt, indivmarkers, xindex, xtypes, nrows, 3, 1, 3) ; if (yxbot < -0.5) continue ;
f2scz(&yytop[5], &yxbot, cupt, indivmarkers, xindex, xtypes, nrows, 3, 2, 3) ; if (yxbot < -0.5) continue ;
ztop += ytop ;
zbot += ybot ;
if ((ytop>0) || (ybot > 0)) ++nsnp ; // monomorphic snps not counted
vvp(zztop, zztop, yytop, 6) ;
}
//verbose = YES ;
ztop /= zbot ;
vst(zztop, zztop, 1.0/zbot, 6) ;
u = zztop[0] ;
vsp(yytop, zztop, -u, 6) ;
s1 = yytop[1] ; /* alpha a */
s2 = yytop[2] ;
atop = yytop[3] ;
btop = yytop[4] ;
alphabot = s1/atop ;
betabot = s2/btop ;
alphatop = 1.0-betabot ;
y1 = -ztop -s1 ;
if (s2>s1) {
alphabot = MAX(alphabot, y1/(s2-s1)) ;
}
if (s2<s1) {
alphatop = MIN(alphatop, y1/(s2-s1)) ;
}
sx = obuff ;
sx += sprintf(sx, "%s", line) ;
//printf(" %12.6f", ztop) ;
sx += sprintf(sx, " %9.3f", alphabot) ;
sx += sprintf(sx, " %9.3f", alphatop) ;
/**
// next code is computing bounds on h (drift -> C)
za = alphatop; zb = 1.0-za ;
ya = s1/za; yb = s2/zb; yt = -za*zb*(ya+yb) ; y1 = ztop - yt ;
za = alphabot; zb = 1.0-za ;
ya = s1/za; yb = s2/zb; yt = -za*zb*(ya+yb) ; y2 = ztop - yt ;
sx += sprintf(sx, " %9.3f %9.3f", y1, y2) ;
sx += sprintf(sx, " %7d", nsnp) ;
*/
printf("%s", obuff) ;
printnl() ;
if (verbose) printmatwl(yytop, 1, 6, 6) ;
if (outputname != NULL) {
fprintf(ofile, "%s\n", obuff) ;
fflush(ofile) ;
}
free(xtypes) ;
free(xindex) ;
free(xindlist) ;
freeup(eglist, 4) ;
destroyaa() ;
return ;
}
Char_Data :: Char_Data() : wearing(this)
{
descr = NULL;
shdata = NULL;
pcdata = NULL;
position = POS_STANDING;
logon = current_time;
save_time = current_time;
cast = NULL;
link = NULL;
enemy = NULL;
leader = NULL;
mount = NULL;
rider = NULL;
next_on_obj = NULL;
pos_obj = NULL;
prepare = NULL;
species = NULL;
pShop = NULL;
reply = NULL;
reset = NULL;
fighting = NULL;
was_in_room = NULL;
in_room = NULL;
pet_name = empty_string;
status = 0;
damroll = 0;
exp = 0;
hit = 0;
hitroll = 0;
mana = 0;
max_hit = 0;
max_mana = 0;
max_move = 0;
mod_con = 0;
mod_dex = 0;
mod_int = 0;
mod_str = 0;
mod_wis = 0;
mod_armor = 0;
mod_hit = 0;
mod_mana = 0;
mod_move = 0;
move = 0;
played = 0;
timer = 0;
move_regen = 0;
mana_regen = 0;
hit_regen = 0;
vzero(mod_resist, MAX_RESIST);
vzero(affected_by, AFFECT_INTS);
active.func = next_action;
active.owner = this;
}
bool remove_coins( char_data* ch, int amount, char* message )
{
obj_data* obj;
obj_data* coin_obj [ 4 ];
int coins [ 4 ];
bool flag = FALSE;
int dum;
int number [] = { 0, 0, 0, 0 };
int pos [ MAX_COIN ];
int neg [ MAX_COIN ];
int i;
vzero( coin_obj, MAX_COIN );
vzero( coins, MAX_COIN );
vzero( number, MAX_COIN );
for( i = 0; i < ch->contents; i++ ) {
obj = (obj_data*) ch->contents[i];
for( int j = 0; j < MAX_COIN; j++ )
if( obj->pIndexData->vnum == coin_vnum[j] ) {
coin_obj[j] = obj;
coins[j] = obj->number;
}
}
for( i = 0; i < MAX_COIN && amount > 0; i++ ) {
amount -= coins[i]*coin_value[i];
number[i] = coins[i];
}
if( amount > 0 )
return FALSE;
amount = -amount;
for( i--; i >= 0; i-- ) {
dum = amount/coin_value[i];
amount -= dum*coin_value[i];
number[i] -= dum;
}
for( i = MAX_COIN - 1; i >= 0; i-- ) {
if( number[i] > 0 )
coin_obj[i]->Extract( number[i] );
pos[i] = max( 0, number[i] );
neg[i] = max( 0, -number[i] );
if( neg[i] != 0 ) {
if( coin_obj[i] == NULL ) {
obj = create( get_obj_index( coin_vnum[i] ), neg[i] );
obj->To( ch );
consolidate( obj );
}
else
coin_obj[i]->number += neg[i];
flag = TRUE;
}
}
if( message != NULL ) {
fsend( ch, "%s%s.\r\n", message, coin_phrase( pos ) );
if( flag )
send( ch, "You receive%s in change.\r\n", coin_phrase( neg ) );
}
return TRUE;
}
Player_Data :: Player_Data(char* name) : locker(this), junked(this)
{
record_new(sizeof(player_data), MEM_PLAYER);
player_list += this;
/*-- INITIALISE VARIABLES --*/
valid = PLAYER_DATA;
switched = NULL;
familiar = NULL;
note_edit = NULL;
atalk = NULL;
gtell = NULL;
ctell = NULL;
chant = NULL;
chat = NULL;
gossip = NULL;
yell = NULL;
shout = NULL;
say = NULL;
tell = NULL;
to = NULL;
whisper = NULL;
base_age = 17;
bank = 0;
noteboard = 0;
gossip_pts = 50;
prayer = 500;
whistle = 0;
timezone = 0;
vzero(iflag, 2);
pcdata = new pc_data;
shdata = new share_data;
descr = new descr_data;
descr->name = alloc_string(name, MEM_DESCR);
pcdata->pfile = NULL;
pcdata->help_edit = NULL;
pcdata->mail_edit = NULL;
pcdata->recognize = NULL;
pcdata->clss = 0;
pcdata->mod_age = 0;
pcdata->piety = 0;
pcdata->speaking = 0;
pcdata->trust = 0;
pcdata->quest_pts = 0;
pcdata->terminal = 0;
pcdata->practice = -1;
pcdata->prac_timer = 5;
pcdata->religion = REL_NONE;
pcdata->lines = 24;
pcdata->max_level = -1;
pcdata->wimpy = 0;
vzero(pcdata->cflags, MAX_CFLAG);
vzero(pcdata->color, MAX_COLOR);
vzero(shdata->skill, MAX_SKILL);
vzero(pcdata->quest_flags, MAX_QUEST);
pcdata->condition[ COND_ALCOHOL ] = 0;
pcdata->condition[ COND_FULL ] = 24;
pcdata->condition[ COND_THIRST ] = 24;
pcdata->condition[ COND_DRUNK ] = 0;
pcdata->tmp_short = empty_string;
pcdata->tmp_keywords = empty_string;
pcdata->title = empty_string;
pcdata->prompt = empty_string;
pcdata->buffer = empty_string;
pcdata->message = (1 << MAX_MESSAGE)-1;
pcdata->mess_settings = 0;
}
void load_objects( void )
{
FILE* fp;
obj_clss_data* obj_clss;
oprog_data* oprog;
char letter;
int i;
int vnum;
echo( "Loading Objects ...\r\n" );
vzero( obj_index_list, MAX_OBJ_INDEX );
fp = open_file( AREA_DIR, OBJECT_FILE, "r", TRUE );
if( strcmp( fread_word( fp ), "#OBJECTS" ) )
panic( "Load_objects: header not found" );
for( ; ; ) {
letter = fread_letter( fp );
if( letter != '#' )
panic( "Load_objects: # not found." );
if( ( vnum = fread_number( fp ) ) == 0 )
break;
if( vnum < 0 || vnum >= MAX_OBJ_INDEX )
panic( "Load_objects: vnum out of range." );
if( obj_index_list[vnum] != NULL )
panic( "Load_objects: vnum %d duplicated.", vnum );
obj_clss = new obj_clss_data;
obj_index_list[vnum] = obj_clss;
obj_clss->vnum = vnum;
obj_clss->fakes = vnum;
obj_clss->singular = fread_string( fp, MEM_OBJ_CLSS );
obj_clss->plural = fread_string( fp, MEM_OBJ_CLSS );
obj_clss->before = fread_string( fp, MEM_OBJ_CLSS );
obj_clss->after = fread_string( fp, MEM_OBJ_CLSS );
obj_clss->long_s = fread_string( fp, MEM_OBJ_CLSS );
obj_clss->long_p = fread_string( fp, MEM_OBJ_CLSS );
obj_clss->prefix_singular = fread_string( fp, MEM_OBJ_CLSS );
obj_clss->prefix_plural = fread_string( fp, MEM_OBJ_CLSS );
obj_clss->creator = fread_string( fp, MEM_OBJ_CLSS );
obj_clss->last_mod = fread_string( fp, MEM_OBJ_CLSS );
obj_clss->item_type = fread_number( fp );
obj_clss->fakes = fread_number( fp );
obj_clss->extra_flags[0] = fread_number( fp );
obj_clss->extra_flags[1] = fread_number( fp );
obj_clss->wear_flags = fread_number( fp );
obj_clss->anti_flags = fread_number( fp );
obj_clss->restrictions = fread_number( fp );
obj_clss->size_flags = fread_number( fp );
obj_clss->materials = fread_number( fp );
obj_clss->affect_flags[0] = fread_number( fp );
obj_clss->affect_flags[1] = fread_number( fp );
obj_clss->affect_flags[2] = fread_number( fp );
obj_clss->layer_flags = fread_number( fp );
obj_clss->value[0] = fread_number( fp );
obj_clss->value[1] = fread_number( fp );
obj_clss->value[2] = fread_number( fp );
obj_clss->value[3] = fread_number( fp );
obj_clss->weight = fread_number( fp );
obj_clss->cost = fread_number( fp );
obj_clss->level = fread_number( fp );
obj_clss->limit = fread_number( fp );
obj_clss->repair = fread_number( fp );
obj_clss->durability = fread_number( fp );
obj_clss->blocks = fread_number( fp );
obj_clss->light = fread_number( fp );
obj_clss->date = fread_number( fp );
read_affects( fp, obj_clss );
read_extra( fp, obj_clss->extra_descr );
fread_letter( fp );
for( ; ; ) {
int number = fread_number( fp );
if( number == -1 )
break;
oprog = new oprog_data;
append( obj_clss->oprog, oprog );
oprog->trigger = number;
oprog->obj_vnum = fread_number( fp );
oprog->command = fread_string( fp, MEM_OPROG );
oprog->target = fread_string( fp, MEM_OPROG );
oprog->code = fread_string( fp, MEM_OPROG );
read_extra( fp, oprog->data );
}
fix( obj_clss );
}
fclose( fp );
for( i = 0; i < MAX_OBJ_INDEX; i++ )
if( obj_index_list[i] != NULL )
for( oprog = obj_index_list[i]->oprog; oprog != NULL;
oprog = oprog->next )
if( oprog->obj_vnum > 0 )
oprog->obj_act = get_obj_index( oprog->obj_vnum );
return;
}
