double calc_forces_eam(double *xi_opt, double *forces, int flag) { int first, col, i; double tmpsum = 0.0, sum = 0.0; double *xi = NULL; static double rho_sum_loc, rho_sum; rho_sum_loc = rho_sum = 0.0; switch (format) { case 0: xi = calc_pot.table; break; case 3: /* fall through */ case 4: xi = xi_opt; /* calc-table is opt-table */ break; case 5: xi = calc_pot.table; /* we need to update the calc-table */ } /* This is the start of an infinite loop */ while (1) { tmpsum = 0.0; /* sum of squares of local process */ rho_sum_loc = 0.0; #if defined APOT && !defined MPI if (0 == format) { apot_check_params(xi_opt); update_calc_table(xi_opt, xi, 0); } #endif /* APOT && !MPI */ #ifdef MPI #ifndef APOT /* exchange potential and flag value */ MPI_Bcast(xi, calc_pot.len, MPI_DOUBLE, 0, MPI_COMM_WORLD); #endif /* APOT */ MPI_Bcast(&flag, 1, MPI_INT, 0, MPI_COMM_WORLD); if (1 == flag) break; /* Exception: flag 1 means clean up */ #ifdef APOT if (0 == myid) apot_check_params(xi_opt); MPI_Bcast(xi_opt, ndimtot, MPI_DOUBLE, 0, MPI_COMM_WORLD); update_calc_table(xi_opt, xi, 0); #else /* APOT */ /* if flag==2 then the potential parameters have changed -> sync */ if (2 == flag) potsync(); #endif /* APOT */ #endif /* MPI */ /* init second derivatives for splines */ /* [0, ..., paircol - 1] = pair potentials */ /* [paircol, ..., paircol + ntypes - 1] = transfer function */ for (col = 0; col < paircol + ntypes; col++) { first = calc_pot.first[col]; if (0 == format || 3 == format) spline_ed(calc_pot.step[col], xi + first, calc_pot.last[col] - first + 1, *(xi + first - 2), 0.0, calc_pot.d2tab + first); else /* format >= 4 ! */ spline_ne(calc_pot.xcoord + first, xi + first, calc_pot.last[col] - first + 1, *(xi + first - 2), 0.0, calc_pot.d2tab + first); } /* [paircol + ntypes, ..., paircol + 2 * ntypes - 1] = embedding function */ #ifndef PARABOLA /* if we have parabolic interpolation, we don't need that */ for (col = paircol + ntypes; col < paircol + 2 * ntypes; col++) { first = calc_pot.first[col]; /* gradient at left boundary matched to square root function, when 0 not in domain(F), else natural spline */ if (0 == format || 3 == format) spline_ed(calc_pot.step[col], xi + first, calc_pot.last[col] - first + 1, #ifdef WZERO ((calc_pot.begin[col] <= 0.0) ? *(xi + first - 2) : 0.5 / xi[first]), ((calc_pot.end[col] >= 0.0) ? *(xi + first - 1) : -0.5 / xi[calc_pot.last[col]]), #else /* WZERO: F is natural spline in any case */ *(xi + first - 2), *(xi + first - 1), #endif /* WZERO */ calc_pot.d2tab + first); else /* format >= 4 ! */ spline_ne(calc_pot.xcoord + first, xi + first, calc_pot.last[col] - first + 1, #ifdef WZERO (calc_pot.begin[col] <= 0.0 ? *(xi + first - 2) : 0.5 / xi[first]), (calc_pot.end[col] >= 0.0 ? *(xi + first - 1) : -0.5 / xi[calc_pot.last[col]]), #else /* WZERO */ *(xi + first - 2), *(xi + first - 1), #endif /* WZERO */ calc_pot.d2tab + first); } #endif /* PARABOLA */ #ifndef MPI myconf = nconf; #endif /* MPI */ /* region containing loop over configurations */ { atom_t *atom; int h, j; int n_i, n_j; int self; int uf; #ifdef APOT double temp_eng; #endif /* APOT */ #ifdef STRESS int us, stresses; #endif /* STRESS */ /* pointer for neighbor table */ neigh_t *neigh; /* pair variables */ double phi_val, phi_grad; double r; vector tmp_force; /* eam variables */ int col_F; double eam_force; double rho_val, rho_grad, rho_grad_j; /* loop over configurations */ for (h = firstconf; h < firstconf + myconf; h++) { uf = conf_uf[h - firstconf]; #ifdef STRESS us = conf_us[h - firstconf]; #endif /* STRESS */ /* reset energies and stresses */ forces[energy_p + h] = 0.0; #ifdef STRESS stresses = stress_p + 6 * h; for (i = 0; i < 6; i++) forces[stresses + i] = 0.0; #endif /* STRESS */ /* set limiting constraints */ forces[limit_p + h] = -force_0[limit_p + h]; /* first loop over atoms: reset forces, densities */ for (i = 0; i < inconf[h]; i++) { n_i = 3 * (cnfstart[h] + i); if (uf) { forces[n_i + 0] = -force_0[n_i + 0]; forces[n_i + 1] = -force_0[n_i + 1]; forces[n_i + 2] = -force_0[n_i + 2]; } else { forces[n_i + 0] = 0.0; forces[n_i + 1] = 0.0; forces[n_i + 2] = 0.0; } /* reset atomic density */ conf_atoms[cnfstart[h] - firstatom + i].rho = 0.0; } /* end of first loop */ /* 2nd loop: calculate pair forces and energies, atomic densities. */ for (i = 0; i < inconf[h]; i++) { atom = conf_atoms + i + cnfstart[h] - firstatom; n_i = 3 * (cnfstart[h] + i); /* loop over neighbors */ for (j = 0; j < atom->num_neigh; j++) { neigh = atom->neigh + j; /* In small cells, an atom might interact with itself */ self = (neigh->nr == i + cnfstart[h]) ? 1 : 0; /* pair potential part */ if (neigh->r < calc_pot.end[neigh->col[0]]) { /* fn value and grad are calculated in the same step */ if (uf) phi_val = splint_comb_dir(&calc_pot, xi, neigh->slot[0], neigh->shift[0], neigh->step[0], &phi_grad); else phi_val = splint_dir(&calc_pot, xi, neigh->slot[0], neigh->shift[0], neigh->step[0]); /* avoid double counting if atom is interacting with a copy of itself */ if (self) { phi_val *= 0.5; phi_grad *= 0.5; } /* add cohesive energy */ forces[energy_p + h] += phi_val; /* calculate forces */ if (uf) { tmp_force.x = neigh->dist_r.x * phi_grad; tmp_force.y = neigh->dist_r.y * phi_grad; tmp_force.z = neigh->dist_r.z * phi_grad; forces[n_i + 0] += tmp_force.x; forces[n_i + 1] += tmp_force.y; forces[n_i + 2] += tmp_force.z; /* actio = reactio */ n_j = 3 * neigh->nr; forces[n_j + 0] -= tmp_force.x; forces[n_j + 1] -= tmp_force.y; forces[n_j + 2] -= tmp_force.z; #ifdef STRESS /* also calculate pair stresses */ if (us) { forces[stresses + 0] -= neigh->dist.x * tmp_force.x; forces[stresses + 1] -= neigh->dist.y * tmp_force.y; forces[stresses + 2] -= neigh->dist.z * tmp_force.z; forces[stresses + 3] -= neigh->dist.x * tmp_force.y; forces[stresses + 4] -= neigh->dist.y * tmp_force.z; forces[stresses + 5] -= neigh->dist.z * tmp_force.x; } #endif /* STRESS */ } } /* neighbor in range */ /* calculate atomic densities */ if (atom->type == neigh->type) { /* then transfer(a->b)==transfer(b->a) */ if (neigh->r < calc_pot.end[neigh->col[1]]) { rho_val = splint_dir(&calc_pot, xi, neigh->slot[1], neigh->shift[1], neigh->step[1]); atom->rho += rho_val; /* avoid double counting if atom is interacting with a copy of itself */ if (!self) { conf_atoms[neigh->nr - firstatom].rho += rho_val; } } } else { /* transfer(a->b)!=transfer(b->a) */ if (neigh->r < calc_pot.end[neigh->col[1]]) { atom->rho += splint_dir(&calc_pot, xi, neigh->slot[1], neigh->shift[1], neigh->step[1]); } /* cannot use slot/shift to access splines */ if (neigh->r < calc_pot.end[paircol + atom->type]) conf_atoms[neigh->nr - firstatom].rho += splint(&calc_pot, xi, paircol + atom->type, neigh->r); } } /* loop over all neighbors */ col_F = paircol + ntypes + atom->type; /* column of F */ #ifndef NORESCALE if (atom->rho > calc_pot.end[col_F]) { /* then punish target function -> bad potential */ forces[limit_p + h] += DUMMY_WEIGHT * 10.0 * dsquare(atom->rho - calc_pot.end[col_F]); #ifndef PARABOLA /* then we use the final value, with PARABOLA: extrapolate */ atom->rho = calc_pot.end[col_F]; #endif /* PARABOLA */ } if (atom->rho < calc_pot.begin[col_F]) { /* then punish target function -> bad potential */ forces[limit_p + h] += DUMMY_WEIGHT * 10.0 * dsquare(calc_pot.begin[col_F] - atom->rho); #ifndef PARABOLA /* then we use the final value, with PARABOLA: extrapolate */ atom->rho = calc_pot.begin[col_F]; #endif /* PARABOLA */ } #endif /* !NORESCALE */ /* embedding energy, embedding gradient */ /* contribution to cohesive energy is F(n) */ #ifdef PARABOLA forces[energy_p + h] += parab_comb(&calc_pot, xi, col_F, atom->rho, &atom->gradF); #elif defined(NORESCALE) if (atom->rho < calc_pot.begin[col_F]) { #ifdef APOT /* calculate analytic value explicitly */ apot_table.fvalue[col_F] (atom->rho, xi_opt + opt_pot.first[col_F], &temp_eng); atom->gradF = apot_grad(atom->rho, xi_opt + opt_pot.first[col_F], apot_table.fvalue[col_F]); forces[energy_p + h] += temp_eng; #else /* linear extrapolation left */ rho_val = splint_comb(&calc_pot, xi, col_F, calc_pot.begin[col_F], &atom->gradF); forces[energy_p + h] += rho_val + (atom->rho - calc_pot.begin[col_F]) * atom->gradF; #endif /* APOT */ } else if (atom->rho > calc_pot.end[col_F]) { #ifdef APOT /* calculate analytic value explicitly */ apot_table.fvalue[col_F] (atom->rho, xi_opt + opt_pot.first[col_F], &temp_eng); atom->gradF = apot_grad(atom->rho, xi_opt + opt_pot.first[col_F], apot_table.fvalue[col_F]); forces[energy_p + h] += temp_eng; #else /* and right */ rho_val = splint_comb(&calc_pot, xi, col_F, calc_pot.end[col_F] - 0.5 * calc_pot.step[col_F], &atom->gradF); forces[energy_p + h] += rho_val + (atom->rho - calc_pot.end[col_F]) * atom->gradF; #endif /* APOT */ } /* and in-between */ else { #ifdef APOT /* calculate small values directly */ if (atom->rho < 0.1) { apot_table.fvalue[col_F] (atom->rho, xi_opt + opt_pot.first[col_F], &temp_eng); atom->gradF = apot_grad(atom->rho, xi_opt + opt_pot.first[col_F], apot_table.fvalue[col_F]); forces[energy_p + h] += temp_eng; } else #endif forces[energy_p + h] += splint_comb(&calc_pot, xi, col_F, atom->rho, &atom->gradF); } #else forces[energy_p + h] += splint_comb(&calc_pot, xi, col_F, atom->rho, &atom->gradF); #endif /* NORESCALE */ /* sum up rho */ rho_sum_loc += atom->rho; } /* second loop over atoms */ /* 3rd loop over atom: EAM force */ if (uf) { /* only required if we calc forces */ for (i = 0; i < inconf[h]; i++) { atom = conf_atoms + i + cnfstart[h] - firstatom; n_i = 3 * (cnfstart[h] + i); for (j = 0; j < atom->num_neigh; j++) { /* loop over neighbors */ neigh = atom->neigh + j; /* In small cells, an atom might interact with itself */ self = (neigh->nr == i + cnfstart[h]) ? 1 : 0; col_F = paircol + ntypes + atom->type; /* column of F */ r = neigh->r; /* are we within reach? */ if ((r < calc_pot.end[neigh->col[1]]) || (r < calc_pot.end[col_F - ntypes])) { rho_grad = (r < calc_pot.end[neigh->col[1]]) ? splint_grad_dir(&calc_pot, xi, neigh->slot[1], neigh->shift[1], neigh->step[1]) : 0.0; if (atom->type == neigh->type) /* use actio = reactio */ rho_grad_j = rho_grad; else rho_grad_j = (r < calc_pot.end[col_F - ntypes]) ? splint_grad(&calc_pot, xi, col_F - ntypes, r) : 0.; /* now we know everything - calculate forces */ eam_force = (rho_grad * atom->gradF + rho_grad_j * conf_atoms[(neigh->nr) - firstatom].gradF); /* avoid double counting if atom is interacting with a copy of itself */ if (self) eam_force *= 0.5; tmp_force.x = neigh->dist_r.x * eam_force; tmp_force.y = neigh->dist_r.y * eam_force; tmp_force.z = neigh->dist_r.z * eam_force; forces[n_i + 0] += tmp_force.x; forces[n_i + 1] += tmp_force.y; forces[n_i + 2] += tmp_force.z; /* actio = reactio */ n_j = 3 * neigh->nr; forces[n_j + 0] -= tmp_force.x; forces[n_j + 1] -= tmp_force.y; forces[n_j + 2] -= tmp_force.z; #ifdef STRESS /* and stresses */ if (us) { forces[stresses + 0] -= neigh->dist.x * tmp_force.x; forces[stresses + 1] -= neigh->dist.y * tmp_force.y; forces[stresses + 2] -= neigh->dist.z * tmp_force.z; forces[stresses + 3] -= neigh->dist.x * tmp_force.y; forces[stresses + 4] -= neigh->dist.y * tmp_force.z; forces[stresses + 5] -= neigh->dist.z * tmp_force.x; } #endif /* STRESS */ } /* within reach */ } /* loop over neighbours */ #ifdef FWEIGHT /* Weigh by absolute value of force */ forces[n_i + 0] /= FORCE_EPS + atom->absforce; forces[n_i + 1] /= FORCE_EPS + atom->absforce; forces[n_i + 2] /= FORCE_EPS + atom->absforce; #endif /* FWEIGHT */ /* sum up forces */ #ifdef CONTRIB if (atom->contrib) #endif /* CONTRIB */ tmpsum += conf_weight[h] * (dsquare(forces[n_i + 0]) + dsquare(forces[n_i + 1]) + dsquare(forces[n_i + 2])); } /* third loop over atoms */ } /* use forces */ /* energy contributions */ forces[energy_p + h] /= (double)inconf[h]; forces[energy_p + h] -= force_0[energy_p + h]; tmpsum += conf_weight[h] * eweight * dsquare(forces[energy_p + h]); #ifdef STRESS /* stress contributions */ if (uf && us) { for (i = 0; i < 6; i++) { forces[stresses + i] /= conf_vol[h - firstconf]; forces[stresses + i] -= force_0[stresses + i]; tmpsum += conf_weight[h] * sweight * dsquare(forces[stresses + i]); } } #endif /* STRESS */ /* limiting constraints per configuration */ tmpsum += conf_weight[h] * dsquare(forces[limit_p + h]); } /* loop over configurations */ } /* parallel region */ #ifdef MPI /* Reduce rho_sum */ rho_sum = 0.0; MPI_Reduce(&rho_sum_loc, &rho_sum, 1, MPI_DOUBLE, MPI_SUM, 0, MPI_COMM_WORLD); #else /* MPI */ rho_sum = rho_sum_loc; #endif /* MPI */ /* dummy constraints (global) */ #ifdef APOT /* add punishment for out of bounds (mostly for powell_lsq) */ if (0 == myid) { tmpsum += apot_punish(xi_opt, forces); } #endif /* APOT */ #ifndef NOPUNISH if (0 == myid) { int g; for (g = 0; g < ntypes; g++) { /* PARABOLA, WZERO, NORESC - different behaviour */ #ifdef PARABOLA /* constraints on U(n) */ forces[dummy_p + ntypes + g] = DUMMY_WEIGHT * parab(&calc_pot, xi, paircol + ntypes + g, 0.0) - force_0[dummy_p + ntypes + g]; /* constraints on U`(n) */ forces[dummy_p + g] = DUMMY_WEIGHT * parab_grad(&calc_pot, xi, paircol + ntypes + g, .5 * (calc_pot.begin[paircol + ntypes + g] + calc_pot.end[paircol + ntypes + g])) - force_0[dummy_p + g]; #elif defined(WZERO) if (calc_pot.begin[paircol + ntypes + g] <= 0.0) /* 0 in domain of U(n) */ /* constraints on U(n) */ forces[dummy_p + ntypes + g] = DUMMY_WEIGHT * splint(&calc_pot, xi, paircol + ntypes + g, 0.0) - force_0[dummy_p + ntypes + g]; else /* 0 not in domain of U(n) */ forces[dummy_p + ntypes + g] = 0.0; /* Free end... */ /* constraints on U`(n) */ forces[dummy_p + g] = DUMMY_WEIGHT * splint_grad(&calc_pot, xi, paircol + ntypes + g, 0.5 * (calc_pot.begin[paircol + ntypes + g] + calc_pot.end[paircol + ntypes + g])) - force_0[dummy_p + g]; #elif defined(NORESCALE) /* clear field */ forces[dummy_p + ntypes + g] = 0.0; /* Free end... */ /* NEW: Constraint on U': U'(1.)=0; */ forces[dummy_p + g] = DUMMY_WEIGHT * splint_grad(&calc_pot, xi, paircol + ntypes + g, 1.0); #else /* NOTHING */ forces[dummy_p + ntypes + g] = 0.0; /* Free end... */ /* constraints on U`(n) */ forces[dummy_p + g] = DUMMY_WEIGHT * splint_grad(&calc_pot, xi, paircol + ntypes + g, 0.5 * (calc_pot.begin[paircol + ntypes + g] + calc_pot.end[paircol + ntypes + g])) - force_0[dummy_p + g]; #endif /* Dummy constraints */ tmpsum += dsquare(forces[dummy_p + ntypes + g]); tmpsum += dsquare(forces[dummy_p + g]); } /* loop over types */ #ifdef NORESCALE /* NEW: Constraint on n: <n>=1. ONE CONSTRAINT ONLY */ /* Calculate averages */ rho_sum /= (double)natoms; /* ATTN: if there are invariant potentials, things might be problematic */ forces[dummy_p + ntypes] = DUMMY_WEIGHT * (rho_sum - 1.0); tmpsum += dsquare(forces[dummy_p + ntypes]); #endif /* NORESCALE */ } /* only root process */ #endif /* !NOPUNISH */ #ifdef MPI /* reduce global sum */ sum = 0.0; MPI_Reduce(&tmpsum, &sum, 1, MPI_DOUBLE, MPI_SUM, 0, MPI_COMM_WORLD); /* gather forces, energies, stresses */ if (0 == myid) { /* root node already has data in place */ /* forces */ MPI_Gatherv(MPI_IN_PLACE, myatoms, MPI_VECTOR, forces, atom_len, atom_dist, MPI_VECTOR, 0, MPI_COMM_WORLD); /* energies */ MPI_Gatherv(MPI_IN_PLACE, myconf, MPI_DOUBLE, forces + natoms * 3, conf_len, conf_dist, MPI_DOUBLE, 0, MPI_COMM_WORLD); /* stresses */ MPI_Gatherv(MPI_IN_PLACE, myconf, MPI_STENS, forces + natoms * 3 + nconf, conf_len, conf_dist, MPI_STENS, 0, MPI_COMM_WORLD); /* punishment constraints */ MPI_Gatherv(MPI_IN_PLACE, myconf, MPI_DOUBLE, forces + natoms * 3 + 7 * nconf, conf_len, conf_dist, MPI_DOUBLE, 0, MPI_COMM_WORLD); } else { /* forces */ MPI_Gatherv(forces + firstatom * 3, myatoms, MPI_VECTOR, forces, atom_len, atom_dist, MPI_VECTOR, 0, MPI_COMM_WORLD); /* energies */ MPI_Gatherv(forces + natoms * 3 + firstconf, myconf, MPI_DOUBLE, forces + natoms * 3, conf_len, conf_dist, MPI_DOUBLE, 0, MPI_COMM_WORLD); /* stresses */ MPI_Gatherv(forces + natoms * 3 + nconf + 6 * firstconf, myconf, MPI_STENS, forces + natoms * 3 + nconf, conf_len, conf_dist, MPI_STENS, 0, MPI_COMM_WORLD); /* punishment constraints */ MPI_Gatherv(forces + natoms * 3 + 7 * nconf + firstconf, myconf, MPI_DOUBLE, forces + natoms * 3 + 7 * nconf, conf_len, conf_dist, MPI_DOUBLE, 0, MPI_COMM_WORLD); } /* no need to pick up dummy constraints - are already @ root */ #else sum = tmpsum; /* global sum = local sum */ #endif /* MPI */ /* root process exits this function now */ if (0 == myid) { fcalls++; /* Increase function call counter */ if (isnan(sum)) { #ifdef DEBUG printf("\n--> Force is nan! <--\n\n"); #endif /* DEBUG */ return 10e10; } else return sum; } } /* end of infinite loop */ /* once a non-root process arrives here, all is done. */ return -1.0; }
DBstatus GE717( DBAny *pstr, DBSeg *pseg, DBTmat *pc, DBfloat rel_leng, DBfloat *pu) /* The function calculates the global parameter value for a * given relative arclength on a curve or a 3D circle. * * In: pstr = The entity * pseg = Optional segments * pc = The active coordinate system * rel_leng = Relative length * * Out: *pu = The parametric value * * (C)microform ab 1992-01-26 G.Liden * * 1994-11-20 comptol added (for surface curves) G Liden * 1996-11-17 Bug: Negative arqument to SQR * Error in parabola creation * TOL2->ctol TOL1->100*comptol G Liden * 1999-05-25 Rewritten, J.Kjellander * 1999-12-18 sur753->varkon_comptol sur751->.._ctol G Liden * 2007-01-22 Added restart with linear method, Sören L * *****************************************************************!*/ { short status; /* Function value from called function */ DBetype type; /* The input curve type */ short noseg; /* Number of segments in the curve */ DBfloat tot_leng; /* Total arclength */ DBfloat abs_leng; /* Absolute arclength (tot_leng*rel_leng) */ DBfloat interv[2]; /* Local u value for GE120 */ DBfloat sum_leng; /* Sum of segment arclengths */ DBfloat dl; /* Arclength for one segment */ short iseg; /* Loop index segment number */ DBfloat delta_leng; /* Delta length= abs_leng-sum_leng */ EVALC evldat; /* For evaluation in GE110() */ short restart; /* 1 will trig restart with linear method */ /* ***Surface computer accuracy and end calulation criterion */ comptol = varkon_comptol(); om_comptol = 1.0 - comptol; ctol = varkon_ctol(); if ( rel_leng < -comptol ) return(erpush("GE7353","GE717")); if ( rel_leng > 1.0 + comptol ) return(erpush("GE7363","GE717")); /* ***Determine the curve type and retrieve noseg. */ type = pstr->hed_un.type; /* ***Line. */ if ( type == LINTYP ) return(erpush("GE7373","GE717")); /* ***2D arc. */ else if ( type == ARCTYP ) { noseg = pstr->arc_un.ns_a; if ( noseg == 0 ) return(erpush("GE7373","GE717")); /* ***3D arc. */ tot_leng = pstr->arc_un.al_a; if ( tot_leng < comptol ) { status = GEarclength(pstr,pseg,&tot_leng); if(status<0)return(erpush("GE8243","GE717")); } } /* ***Curve. */ else if ( type == CURTYP ) { noseg = pstr->cur_un.ns_cu; tot_leng = pstr->cur_un.al_cu; if ( tot_leng < comptol ) { status = GEarclength(pstr,pseg,&tot_leng); if(status<0)return(erpush("GE8243","GE717")); } } /* ***Illegal entity type. */ else return(erpush("GE7993","GE717,wrong type")); /* ***If rel_leng is zero (<comptol) or one (>1-comptol) ***we can make it really simple. */ if ( rel_leng < comptol ) { *pu = 1.0; return(0); } if ( rel_leng > om_comptol ) { *pu = (DBfloat)(noseg + 1); return(0); } /* ***The absolute length abs_leng = tot_leng*rel_leng. */ abs_leng = tot_leng*rel_leng; /* ***Evaluation needed by GE110(). */ evldat.evltyp = EVC_DR; /* ***Retrieve segment arclengths until sum exceeds abs_leng */ sum_leng = 0.0; interv[0] = 0.0; interv[1] = 1.0; for ( iseg=0; iseg<noseg; iseg++ ) { dl = (pseg+iseg)->sl; sum_leng += dl; if (sum_leng > abs_leng ) break; } /* ***Normaly the function will not restart, but if it fails ***it will try once also with linear method, not using parab() */ restart=-1; restart: restart++; /* ***The relative arclength is in segment iseg ***Delta arclength in the segment delta_leng= dl-(sum_leng-abs_leng) */ delta_leng = dl - (sum_leng - abs_leng); /* ***Start value ulocal = delta_leng/dl for the numerical solution */ if ( ABS(dl) >= comptol ) ulocal = delta_leng/dl; else return(erpush("GE7993","GE717, ABS(dl)>=comptol")); /* ***Numerical solution for find X for F(X)=0 ***Initialisation of loop variables. */ no_iter = interv[0] = 0.0; if ( ulocal < 0.5 ) { ulocal_pre = comptol; f_pre = -delta_leng; } else { ulocal_pre = om_comptol; f_pre = dl - delta_leng; } /* ***Next iteration. */ loop: ++no_iter; if ( no_iter > 10 ) { if (restart==0) goto restart; else if ( no_iter > 20 ) return(erpush("GE7993","GE717 (no_iter)")); } /* ***Calculation of function value f and derivative dfdu */ if ( ulocal < -4.0 ) return(erpush("GE7993","GE717 (u<-4.0)")); if ( ulocal > 4.0 ) return(erpush("GE7993","GE717 (u>4.0)")); interv[1] = ulocal; status = GE120(pstr,pseg+iseg,interv,&dl); if ( status < 0 ) return(erpush("GE1273","GE717 (loop)")); evldat.t_local = ulocal; GE110(pstr,pseg+iseg,&evldat); f = dl - delta_leng; dfdu = SQRT(evldat.drdt.x_gm*evldat.drdt.x_gm + evldat.drdt.y_gm*evldat.drdt.y_gm + evldat.drdt.z_gm*evldat.drdt.z_gm); /* ***Optimal point if function value f < ctol. */ if ( ABS(f) < ctol ) { *pu = (DBfloat)(iseg + 1) + ulocal; goto end; } if ( ABS(dfdu) < comptol ) return(erpush("GE7993","GE717")); /* ***Next ulocal = ulocal-f/dfdu and goto loop ***A Newton-Rhapson (linear interpolation) solution would be *** ulocal_pre = ulocal; *** f_pre = f; *** ulocal= ulocal-f/dfdu; ***Normally (geo102) a linear method is faster in the beginning ***but in this case (hyperbola p=0.95) will Newton-Rhapson fail ***Parabola (second degree) interpolation. */ if (restart) /* use linear method */ { ulocal_pre = ulocal; f_pre = f; ulocal= ulocal-f/dfdu; } else parab(); goto loop; /* ***Label end: Optimal point */ end: return(0); }