double testLambda(double * wi,double * vi, double * w, double v, prox_data * p_data, int i, double lambda){
double sumu = 0;
for ( int k = 1; k <= *(p_data->connections[i]); k++ ){
wi[k-1] = -fminl(-fminl(w[p_data->connections[i][k]]-lambda,p_data->U),0);
sumu += wi[k-1];
}
*vi = -fminl(-fminl(v+lambda,p_data->C),0);
return sumu;
}
int main(void)
{
#pragma STDC FENV_ACCESS ON
long double y;
float d;
int e, i, err = 0;
struct ll_l *p;
for (i = 0; i < sizeof t/sizeof *t; i++) {
p = t + i;
if (p->r < 0)
continue;
fesetround(p->r);
feclearexcept(FE_ALL_EXCEPT);
y = fminl(p->x, p->x2);
e = fetestexcept(INEXACT|INVALID|DIVBYZERO|UNDERFLOW|OVERFLOW);
if (!checkexceptall(e, p->e, p->r)) {
printf("%s:%d: bad fp exception: %s fminl(%La,%La)=%La, want %s",
p->file, p->line, rstr(p->r), p->x, p->x2, p->y, estr(p->e));
printf(" got %s\n", estr(e));
err++;
}
d = ulperrl(y, p->y, p->dy);
if (!checkcr(y, p->y, p->r)) {
printf("%s:%d: %s fminl(%La,%La) want %La got %La ulperr %.3f = %a + %a\n",
p->file, p->line, rstr(p->r), p->x, p->x2, p->y, y, d, d-p->dy, p->dy);
err++;
}
}
return !!err;
}
void test_fmin()
{
static_assert((std::is_same<decltype(fmin((double)0, (double)0)), double>::value), "");
static_assert((std::is_same<decltype(fminf(0,0)), float>::value), "");
static_assert((std::is_same<decltype(fminl(0,0)), long double>::value), "");
assert(fmin(1,0) == 0);
}
void clenshaw(int N, double coeff, double *vecin, double alpha, double *temp2, double beta, double *vecout, double scl, double *temp1) {
// thread variables
int nthds, tid;
// compute variables
int stride, start, stop, ii;
double temp;
/* Fork a team of threads giving them their own copies of variables */
#pragma omp parallel private(nthds, tid, stride, start, stop, ii, temp) shared(N, coeff, vecin, alpha, temp2, beta, vecout, scl, temp1)
{
// compute thread variables
nthds = omp_get_num_threads();
tid = omp_get_thread_num();
// compute stride
stride = ceil((long double)N/nthds);
// compute start and stop
start = tid*stride;
stop = (int)fminl((long double)(tid+1)*stride,(long double)N);
// print info
//printf("id, stride, start, stop = %d, %10d, %10d, %10d\n",tid,stride,start,stop);
// initialize vec
for(ii=start;ii<stop;ii++){
temp = vecout[ii];
vecout[ii] = coeff*vecin[ii] + alpha*temp2[ii] + beta*vecout[ii] + scl*temp1[ii];
temp1[ii] = temp;
}
} /* All threads join master thread and disband */
}
void init(int N, double scl, double *vec){
// thread variables
int nthds, tid;
// compute variables
int stride, start, stop, ii;
/* Fork a team of threads giving them their own copies of variables */
#pragma omp parallel private(nthds, tid, stride, start, stop, ii) shared(N, scl, vec)
{
// compute thread variables
nthds = omp_get_num_threads();
tid = omp_get_thread_num();
// compute stride
stride = ceil((long double)N/nthds);
// compute start and stop
start = tid*stride;
stop = (int)fminl((long double)(tid+1)*stride,(long double)N);
// print info
//printf("id, stride, start, stop = %d, %10d, %10d, %10d\n",tid,stride,start,stop);
// initialize vec
for(ii=start;ii<stop;ii++){
vec[ii] = scl;
}
} /* All threads join master thread and disband */
}
/* configure a sensors stream */
extern int32_t irobotSensorStreamConfigure(
const irobotUARTPort_t port, /* (in) irobot UART port */
const irobotSensorCode * const sensorCodes, /* (in) array of sensor codes (must be nSensorCodes in size) */
const uint8_t nSensorCodes /* (in) number of sensors in each stream packet */
) { /* (ret) error / success code */
uint8_t packet[OP_SENSOR_STREAM_MAX_SIZE];
uint8_t packetIndex = 0;
uint8_t sensorCodeIndex = 0;
/* check for NULL pointers */
if(nSensorCodes && !sensorCodes) {
return ERROR_INVALID_PARAMETER;
}
packet[packetIndex++] = OP_STREAM;
packet[packetIndex++] = fminl(nSensorCodes, OP_SENSOR_STREAM_MAX_CODES);
for(sensorCodeIndex = 0; sensorCodeIndex < fminl(nSensorCodes, OP_SENSOR_STREAM_MAX_CODES); sensorCodeIndex++) {
packet[packetIndex++] = sensorCodes[sensorCodeIndex];
}
return irobotUARTWriteRaw(port, packet, packetIndex);
}
double dot(int N, double *vec1, double *vec2){
// thread variables
int nthds, tid;
// compute variables
int m, stride, start, stop;
double dot;
/* Fork a team of threads giving them their own copies of variables */
#pragma omp parallel private(nthds, tid) shared(m)
{
// compute thread variables
nthds = omp_get_num_threads();
tid = omp_get_thread_num();
if(tid == 0){
m = nthds;
}
}
//printf("m = %d\n",m);
double pnrms[m];
/* Fork a team of threads giving them their own copies of variables */
#pragma omp parallel private(nthds, tid, stride, start, stop) shared(N, vec1, vec2, pnrms)
{
// compute thread variables
nthds = omp_get_num_threads();
tid = omp_get_thread_num();
// compute stride
stride = ceil((long double)N/nthds);
// compute start and stop
start = tid*stride;
stop = (int)fminl((long double)(tid+1)*stride,(long double)N);
pnrms[tid] = cblas_ddot(stop-start,&vec1[start],1,&vec2[start],1);
//printf("pnrms[%d] = %+e\n",tid,pnrms[tid]);
}
dot = cblas_dasum(m,&pnrms[0],1);
//printf("nrm = %+e\n",nrm);
return dot;
}
void prox(prob_vars * vars, all_data * data, prox_data * p_data)
{
memcpy(vars->x_t,vars->x,data->n*(data->T+1)*sizeof(double));
subArray(vars->x_t,vars->z,data->n*(data->T+1));
memcpy(vars->u_t,vars->u,data->m*(data->T+1)*sizeof(double));
subArray(vars->u_t,vars->y,data->m*(data->T+1));
/* The proximal step using bisection (x_t, u_t) */
int idx;
#pragma omp parallel for private(idx)
for ( int t = 0; t < data->T+1; t++ ) {
for ( int j = 0; j < p_data->numsource; j++ ) {
idx = t*data->m + p_data->idx_source[j];
/* Saturate the inputs */
vars->u_t[idx] = -fminl(-fminl(vars->u_t[idx],p_data->U), 0);
}
for ( int i = 0; i < data->n; i++ ){ /* For every node... */
idx = t*data->n+i;
bisection(data,&(vars->u_t[t*data->m]), &(vars->x_t[idx]), p_data, i);
}
}
}
void prox(prob_vars * vars, all_data * data, prox_data * p_data)
{
double v[data->m*(data->T+1)];
memcpy(v,vars->u,sizeof(double)*data->m*(data->T+1));
subArray(v,vars->y,data->m*(data->T+1));
memcpy(vars->x_t,vars->x,sizeof(double)*data->n*(data->T+1));
subArray(vars->x_t,vars->z,data->n*(data->T+1));
double nm,fac;
// #pragma omp parallel for private(nm,fac)
for(int i=0;i<data->T+1;i++){
nm = nrm(&v[i*data->m],data->m);
fac = 1-fminl(1/(1+data->rho),p_data->M/(data->rho*nm));
for(int j=0;j<data->m;j++){
vars->u_t[i*data->m+j]=fac*v[i*data->m+j];
}
}
}
void lap(int N, double scl, double *vecin, double *vecout){
// thread variables
int nthds, tid;
// compute variables
int stride, start, stop, ii;
/* Fork a team of threads giving them their own copies of variables */
#pragma omp parallel private(nthds, tid, stride, start, stop, ii) shared(N, scl, vecin, vecout)
{
// compute thread variables
nthds = omp_get_num_threads();
tid = omp_get_thread_num();
// compute stride
stride = ceil((long double)N/nthds);
// compute start and stop
start = tid*stride;
stop = (int)fminl((long double)(tid+1)*stride,(long double)N);
// print info
//printf("id, stride, start, stop = %d, %10d, %10d, %10d\n",tid,stride,start,stop);
// multiply vecin by lap and write to vecout
for(ii=start;ii<stop;ii++){
if(ii == 0){
vecout[ii] = (2.0*vecin[ii] - vecin[ii+1])/scl;
}
else if(ii == N-1){
vecout[ii] = (2.0*vecin[ii] - vecin[ii-1])/scl;
}
else if(ii < N){
vecout[ii] = (2.0*vecin[ii] - vecin[ii+1] - vecin[ii-1])/scl;
}
}
} /* All threads join master thread and disband */
}
/**
* @brief SpectrogramData::append Appends data to spectrogram
* @param obj UAVO with new data
* @return
*/
bool SpectrogramData::append(UAVObject* multiObj)
{
QDateTime NOW = QDateTime::currentDateTime(); //TODO: Upgrade this to show UAVO time and not system time
// Check to make sure it's the correct UAVO
if (uavObjectName == multiObj->getName()) {
// Only run on UAVOs that have multiple instances
if (multiObj->isSingleInstance())
return false;
//Instantiate object manager
UAVObjectManager *objManager;
ExtensionSystem::PluginManager *pm = ExtensionSystem::PluginManager::instance();
Q_ASSERT(pm != NULL);
objManager = pm->getObject<UAVObjectManager>();
Q_ASSERT(objManager != NULL);
// Get list of object instances
QVector<UAVObject*> list = objManager->getObjectInstancesVector(multiObj->getName());
// Remove a row's worth of data.
unsigned int spectrogramWidth = list.size();
// Check that there is a full window worth of data. While GCS is starting up, the size of
// multiple instance UAVOs is 1, so it's possible for spurious data to come in before
// the flight controller board has had time to initialize the UAVO size.
if (spectrogramWidth != windowWidth){
qDebug() << "Incomplete data set in" << multiObj->getName() << "." << uavFieldName << "spectrogram: " << spectrogramWidth << " samples provided, but expected " << windowWidth;
return false;
}
//Initialize vector where we will read out an entire row of multiple instance UAVO
QVector<double> values;
timeDataHistory->append(NOW.toTime_t() + NOW.time().msec() / 1000.0);
UAVObjectField* multiField = multiObj->getField(uavFieldName);
Q_ASSERT(multiField);
if (multiField ) {
// Get the field of interest
foreach (UAVObject *obj, list) {
UAVObjectField* field = obj->getField(uavFieldName);
double currentValue = valueAsDouble(obj, field, haveSubField, uavSubFieldName) * pow(10, scalePower);
double vecVal = currentValue;
//Normally some math would go here, modifying vecVal before appending it to values
// .
// .
// .
// Second to last step, see if autoscale is turned on and if the value exceeds the maximum for the scope.
if ( zMaximum == 0 && vecVal > rasterData->interval(Qt::ZAxis).maxValue()){
// Change scope maximum and color depth
rasterData->setInterval(Qt::ZAxis, QwtInterval(0, vecVal) );
autoscaleValueUpdated = vecVal;
}
// Last step, assign value to vector
values += vecVal;
}
while (timeDataHistory->back() - timeDataHistory->front() > timeHorizon){
timeDataHistory->pop_front();
zDataHistory->remove(0, fminl(spectrogramWidth, zDataHistory->size()));
}
// Doublecheck that there are the right number of samples. This can occur if the "field" assert fails
if(values.size() == (int) windowWidth){
*zDataHistory << values;
}
return true;
}
}
TEST(math, fminl) {
ASSERT_FLOAT_EQ(10.0, fminl(12.0, 10.0));
ASSERT_FLOAT_EQ(12.0, fminl(12.0, nan("")));
ASSERT_FLOAT_EQ(12.0, fminl(nan(""), 12.0));
}
static int testl(long double long_double_x, int int_x, long long_x)
{
int r = 0;
r += __finitel(long_double_x);
r += __fpclassifyl(long_double_x);
r += __isinfl(long_double_x);
r += __isnanl(long_double_x);
r += __signbitl(long_double_x);
r += acoshl(long_double_x);
r += acosl(long_double_x);
r += asinhl(long_double_x);
r += asinl(long_double_x);
r += atan2l(long_double_x, long_double_x);
r += atanhl(long_double_x);
r += atanl(long_double_x);
r += cbrtl(long_double_x);
r += ceill(long_double_x);
r += copysignl(long_double_x, long_double_x);
r += coshl(long_double_x);
r += cosl(long_double_x);
r += erfcl(long_double_x);
r += erfl(long_double_x);
r += exp2l(long_double_x);
r += expl(long_double_x);
r += expm1l(long_double_x);
r += fabsl(long_double_x);
r += fdiml(long_double_x, long_double_x);
r += floorl(long_double_x);
r += fmal(long_double_x, long_double_x, long_double_x);
r += fmaxl(long_double_x, long_double_x);
r += fminl(long_double_x, long_double_x);
r += fmodl(long_double_x, long_double_x);
r += frexpl(long_double_x, &int_x);
r += hypotl(long_double_x, long_double_x);
r += ilogbl(long_double_x);
r += ldexpl(long_double_x, int_x);
r += lgammal(long_double_x);
r += llrintl(long_double_x);
r += llroundl(long_double_x);
r += log10l(long_double_x);
r += log1pl(long_double_x);
r += log2l(long_double_x);
r += logbl(long_double_x);
r += logl(long_double_x);
r += lrintl(long_double_x);
r += lroundl(long_double_x);
r += modfl(long_double_x, &long_double_x);
r += nearbyintl(long_double_x);
r += nextafterl(long_double_x, long_double_x);
r += nexttowardl(long_double_x, long_double_x);
r += powl(long_double_x, long_double_x);
r += remainderl(long_double_x, long_double_x);
r += remquol(long_double_x, long_double_x, &int_x);
r += rintl(long_double_x);
r += roundl(long_double_x);
r += scalblnl(long_double_x, long_x);
r += scalbnl(long_double_x, int_x);
r += sinhl(long_double_x);
r += sinl(long_double_x);
r += sqrtl(long_double_x);
r += tanhl(long_double_x);
r += tanl(long_double_x);
r += tgammal(long_double_x);
r += truncl(long_double_x);
return r;
}
void
domathl (void)
{
#ifndef NO_LONG_DOUBLE
long double f1;
long double f2;
int i1;
f1 = acosl(0.0);
fprintf( stdout, "acosl : %Lf\n", f1);
f1 = acoshl(0.0);
fprintf( stdout, "acoshl : %Lf\n", f1);
f1 = asinl(1.0);
fprintf( stdout, "asinl : %Lf\n", f1);
f1 = asinhl(1.0);
fprintf( stdout, "asinhl : %Lf\n", f1);
f1 = atanl(M_PI_4);
fprintf( stdout, "atanl : %Lf\n", f1);
f1 = atan2l(2.3, 2.3);
fprintf( stdout, "atan2l : %Lf\n", f1);
f1 = atanhl(1.0);
fprintf( stdout, "atanhl : %Lf\n", f1);
f1 = cbrtl(27.0);
fprintf( stdout, "cbrtl : %Lf\n", f1);
f1 = ceill(3.5);
fprintf( stdout, "ceill : %Lf\n", f1);
f1 = copysignl(3.5, -2.5);
fprintf( stdout, "copysignl : %Lf\n", f1);
f1 = cosl(M_PI_2);
fprintf( stdout, "cosl : %Lf\n", f1);
f1 = coshl(M_PI_2);
fprintf( stdout, "coshl : %Lf\n", f1);
f1 = erfl(42.0);
fprintf( stdout, "erfl : %Lf\n", f1);
f1 = erfcl(42.0);
fprintf( stdout, "erfcl : %Lf\n", f1);
f1 = expl(0.42);
fprintf( stdout, "expl : %Lf\n", f1);
f1 = exp2l(0.42);
fprintf( stdout, "exp2l : %Lf\n", f1);
f1 = expm1l(0.00042);
fprintf( stdout, "expm1l : %Lf\n", f1);
f1 = fabsl(-1.123);
fprintf( stdout, "fabsl : %Lf\n", f1);
f1 = fdiml(1.123, 2.123);
fprintf( stdout, "fdiml : %Lf\n", f1);
f1 = floorl(0.5);
fprintf( stdout, "floorl : %Lf\n", f1);
f1 = floorl(-0.5);
fprintf( stdout, "floorl : %Lf\n", f1);
f1 = fmal(2.1, 2.2, 3.01);
fprintf( stdout, "fmal : %Lf\n", f1);
f1 = fmaxl(-0.42, 0.42);
fprintf( stdout, "fmaxl : %Lf\n", f1);
f1 = fminl(-0.42, 0.42);
fprintf( stdout, "fminl : %Lf\n", f1);
f1 = fmodl(42.0, 3.0);
fprintf( stdout, "fmodl : %Lf\n", f1);
/* no type-specific variant */
i1 = fpclassify(1.0);
fprintf( stdout, "fpclassify : %d\n", i1);
f1 = frexpl(42.0, &i1);
fprintf( stdout, "frexpl : %Lf\n", f1);
f1 = hypotl(42.0, 42.0);
fprintf( stdout, "hypotl : %Lf\n", f1);
i1 = ilogbl(42.0);
fprintf( stdout, "ilogbl : %d\n", i1);
/* no type-specific variant */
i1 = isfinite(3.0);
fprintf( stdout, "isfinite : %d\n", i1);
/* no type-specific variant */
i1 = isgreater(3.0, 3.1);
fprintf( stdout, "isgreater : %d\n", i1);
/* no type-specific variant */
i1 = isgreaterequal(3.0, 3.1);
fprintf( stdout, "isgreaterequal : %d\n", i1);
/* no type-specific variant */
i1 = isinf(3.0);
fprintf( stdout, "isinf : %d\n", i1);
/* no type-specific variant */
i1 = isless(3.0, 3.1);
fprintf( stdout, "isless : %d\n", i1);
/* no type-specific variant */
i1 = islessequal(3.0, 3.1);
fprintf( stdout, "islessequal : %d\n", i1);
/* no type-specific variant */
i1 = islessgreater(3.0, 3.1);
fprintf( stdout, "islessgreater : %d\n", i1);
/* no type-specific variant */
i1 = isnan(0.0);
fprintf( stdout, "isnan : %d\n", i1);
/* no type-specific variant */
i1 = isnormal(3.0);
fprintf( stdout, "isnormal : %d\n", i1);
/* no type-specific variant */
f1 = isunordered(1.0, 2.0);
fprintf( stdout, "isunordered : %d\n", i1);
f1 = j0l(1.2);
fprintf( stdout, "j0l : %Lf\n", f1);
f1 = j1l(1.2);
fprintf( stdout, "j1l : %Lf\n", f1);
f1 = jnl(2,1.2);
fprintf( stdout, "jnl : %Lf\n", f1);
f1 = ldexpl(1.2,3);
fprintf( stdout, "ldexpl : %Lf\n", f1);
f1 = lgammal(42.0);
fprintf( stdout, "lgammal : %Lf\n", f1);
f1 = llrintl(-0.5);
fprintf( stdout, "llrintl : %Lf\n", f1);
f1 = llrintl(0.5);
fprintf( stdout, "llrintl : %Lf\n", f1);
f1 = llroundl(-0.5);
fprintf( stdout, "lroundl : %Lf\n", f1);
f1 = llroundl(0.5);
fprintf( stdout, "lroundl : %Lf\n", f1);
f1 = logl(42.0);
fprintf( stdout, "logl : %Lf\n", f1);
f1 = log10l(42.0);
fprintf( stdout, "log10l : %Lf\n", f1);
f1 = log1pl(42.0);
fprintf( stdout, "log1pl : %Lf\n", f1);
f1 = log2l(42.0);
fprintf( stdout, "log2l : %Lf\n", f1);
f1 = logbl(42.0);
fprintf( stdout, "logbl : %Lf\n", f1);
f1 = lrintl(-0.5);
fprintf( stdout, "lrintl : %Lf\n", f1);
f1 = lrintl(0.5);
fprintf( stdout, "lrintl : %Lf\n", f1);
f1 = lroundl(-0.5);
fprintf( stdout, "lroundl : %Lf\n", f1);
f1 = lroundl(0.5);
fprintf( stdout, "lroundl : %Lf\n", f1);
f1 = modfl(42.0,&f2);
fprintf( stdout, "lmodfl : %Lf\n", f1);
f1 = nanl("");
fprintf( stdout, "nanl : %Lf\n", f1);
f1 = nearbyintl(1.5);
fprintf( stdout, "nearbyintl : %Lf\n", f1);
f1 = nextafterl(1.5,2.0);
fprintf( stdout, "nextafterl : %Lf\n", f1);
f1 = powl(3.01, 2.0);
fprintf( stdout, "powl : %Lf\n", f1);
f1 = remainderl(3.01,2.0);
fprintf( stdout, "remainderl : %Lf\n", f1);
f1 = remquol(29.0,3.0,&i1);
fprintf( stdout, "remquol : %Lf\n", f1);
f1 = rintl(0.5);
fprintf( stdout, "rintl : %Lf\n", f1);
f1 = rintl(-0.5);
fprintf( stdout, "rintl : %Lf\n", f1);
f1 = roundl(0.5);
fprintf( stdout, "roundl : %Lf\n", f1);
f1 = roundl(-0.5);
fprintf( stdout, "roundl : %Lf\n", f1);
f1 = scalblnl(1.2,3);
fprintf( stdout, "scalblnl : %Lf\n", f1);
f1 = scalbnl(1.2,3);
fprintf( stdout, "scalbnl : %Lf\n", f1);
/* no type-specific variant */
i1 = signbit(1.0);
fprintf( stdout, "signbit : %i\n", i1);
f1 = sinl(M_PI_4);
fprintf( stdout, "sinl : %Lf\n", f1);
f1 = sinhl(M_PI_4);
fprintf( stdout, "sinhl : %Lf\n", f1);
f1 = sqrtl(9.0);
fprintf( stdout, "sqrtl : %Lf\n", f1);
f1 = tanl(M_PI_4);
fprintf( stdout, "tanl : %Lf\n", f1);
f1 = tanhl(M_PI_4);
fprintf( stdout, "tanhl : %Lf\n", f1);
f1 = tgammal(2.1);
fprintf( stdout, "tgammal : %Lf\n", f1);
f1 = truncl(3.5);
fprintf( stdout, "truncl : %Lf\n", f1);
f1 = y0l(1.2);
fprintf( stdout, "y0l : %Lf\n", f1);
f1 = y1l(1.2);
fprintf( stdout, "y1l : %Lf\n", f1);
f1 = ynl(3,1.2);
fprintf( stdout, "ynl : %Lf\n", f1);
#endif
}
void test2l(long double x, long double y)
{
if (-tanl(x-y) != tanl(y-x))
link_error ();
if (-sinl(x-y) != sinl(y-x))
link_error ();
if (cosl(-x*y) != cosl(x*y))
link_error ();
if (cosl(x*-y) != cosl(x*y))
link_error ();
if (cosl(-x/y) != cosl(x/y))
link_error ();
if (cosl(x/-y) != cosl(x/y))
link_error ();
if (cosl(-fabsl(tanl(x/-y))) != cosl(tanl(x/y)))
link_error ();
if (cosl(y<10 ? -x : y) != cosl(y<10 ? x : y))
link_error ();
if (cosl(y<10 ? x : -y) != cosl(y<10 ? x : y))
link_error ();
if (cosl(y<10 ? -fabsl(x) : tanl(x<20 ? -x : -fabsl(y)))
!= cosl(y<10 ? x : tanl(x<20 ? x : y)))
link_error ();
if (cosl((y*=3, -x)) != cosl((y*=3,x)))
link_error ();
if (cosl((y*=2, -fabsl(tanl(x/-y)))) != cosl((y*=2,tanl(x/y))))
link_error ();
if (cosl(copysignl(x,y)) != cosl(x))
link_error ();
if (cosl(copysignl(-fabsl(x),y*=2)) != cosl((y*=2,x)))
link_error ();
if (hypotl (x, 0) != fabsl(x))
link_error ();
if (hypotl (0, x) != fabsl(x))
link_error ();
if (hypotl (x, x) != fabsl(x) * __builtin_sqrtl(2))
link_error ();
if (hypotl (-x, y) != hypotl (x, y))
link_error ();
if (hypotl (x, -y) != hypotl (x, y))
link_error ();
if (hypotl (-x, -y) != hypotl (x, y))
link_error ();
if (hypotl (fabsl(x), y) != hypotl (x, y))
link_error ();
if (hypotl (x, fabsl(y)) != hypotl (x, y))
link_error ();
if (hypotl (fabsl(x), fabsl(y)) != hypotl (x, y))
link_error ();
if (hypotl (-fabsl(-x), -fabsl(fabsl(fabsl(-y)))) != hypotl (x, y))
link_error ();
if (hypotl (-x, 0) != fabsl(x))
link_error ();
if (hypotl (-x, x) != fabsl(x) * __builtin_sqrtl(2))
link_error ();
if (hypotl (purel(x), -purel(x)) != fabsl(purel(x)) * __builtin_sqrtl(2))
link_error ();
if (hypotl (tanl(-x), tanl(-fabsl(y))) != hypotl (tanl(x), tanl(y)))
link_error ();
if (fminl (fmaxl(x,y),y) != y)
link_error ();
if (fminl (fmaxl(y,x),y) != y)
link_error ();
if (fminl (x,fmaxl(x,y)) != x)
link_error ();
if (fminl (x,fmaxl(y,x)) != x)
link_error ();
if (fmaxl (fminl(x,y),y) != y)
link_error ();
if (fmaxl (fminl(y,x),y) != y)
link_error ();
if (fmaxl (x,fminl(x,y)) != x)
link_error ();
if (fmaxl (x,fminl(y,x)) != x)
link_error ();
if ((__complex__ long double) x != -(__complex__ long double) (-x))
link_error ();
if (x+(x-y)*1i != -(-x+(y-x)*1i))
link_error ();
if (x+(x-y)*1i != -(-x-(x-y)*1i))
link_error ();
if (ccosl(tanl(x)+sinl(y)*1i) != ccosl(-tanl(-x)+-sinl(-y)*1i))
link_error ();
if (ccosl(tanl(x)+sinl(x-y)*1i) != ccosl(-tanl(-x)-sinl(y-x)*1i))
link_error ();
if (-5+x*1i != -~(5+x*1i))
link_error ();
if (tanl(x)+tanl(y)*1i != -~(tanl(-x)+tanl(y)*1i))
link_error ();
}
Ref<Result> Code128Reader::decodeRow(int rowNumber, Ref<BitArray> row) {
int* startPatternInfo = NULL;
try {
startPatternInfo = findStartPattern(row);
int startCode = startPatternInfo[2];
int codeSet;
switch (startCode) {
case CODE_START_A:
codeSet = CODE_CODE_A;
break;
case CODE_START_B:
codeSet = CODE_CODE_B;
break;
case CODE_START_C:
codeSet = CODE_CODE_C;
break;
default:
throw ReaderException("");
}
bool done = false;
bool isNextShifted = false;
std::string tmpResultString;
std::stringstream tmpResultSStr; // used if its Code 128C
int lastStart = startPatternInfo[0];
int nextStart = startPatternInfo[1];
int counters[countersLength] = {0,0,0,0,0,0};
int lastCode = 0;
int code = 0;
int checksumTotal = startCode;
int multiplier = 0;
bool lastCharacterWasPrintable = true;
while (!done) {
bool unshift = isNextShifted;
isNextShifted = false;
// Save off last code
lastCode = code;
// Decode another code from image
try {
code = decodeCode(row, counters, sizeof(counters)/sizeof(int), nextStart);
} catch (ReaderException const& re) {
throw re;
}
// Remember whether the last code was printable or not (excluding CODE_STOP)
if (code != CODE_STOP) {
lastCharacterWasPrintable = true;
}
// Add to checksum computation (if not CODE_STOP of course)
if (code != CODE_STOP) {
multiplier++;
checksumTotal += multiplier * code;
}
// Advance to where the next code will to start
lastStart = nextStart;
int _countersLength = sizeof(counters) / sizeof(int);
for (int i = 0; i < _countersLength; i++) {
nextStart += counters[i];
}
// Take care of illegal start codes
switch (code) {
case CODE_START_A:
case CODE_START_B:
case CODE_START_C:
throw ReaderException("");
}
switch (codeSet) {
case CODE_CODE_A:
if (code < 64) {
tmpResultString.append(1, (char) (' ' + code));
} else if (code < 96) {
tmpResultString.append(1, (char) (code - 64));
} else {
// Don't let CODE_STOP, which always appears, affect whether whether we think the
// last code was printable or not.
if (code != CODE_STOP) {
lastCharacterWasPrintable = false;
}
switch (code) {
case CODE_FNC_1:
case CODE_FNC_2:
case CODE_FNC_3:
case CODE_FNC_4_A:
// do nothing?
break;
case CODE_SHIFT:
isNextShifted = true;
codeSet = CODE_CODE_B;
break;
case CODE_CODE_B:
codeSet = CODE_CODE_B;
break;
case CODE_CODE_C:
codeSet = CODE_CODE_C;
break;
case CODE_STOP:
done = true;
break;
}
}
break;
case CODE_CODE_B:
if (code < 96) {
tmpResultString.append(1, (char) (' ' + code));
} else {
if (code != CODE_STOP) {
lastCharacterWasPrintable = false;
}
switch (code) {
case CODE_FNC_1:
case CODE_FNC_2:
case CODE_FNC_3:
case CODE_FNC_4_B:
// do nothing?
break;
case CODE_SHIFT:
isNextShifted = true;
codeSet = CODE_CODE_C;
break;
case CODE_CODE_A:
codeSet = CODE_CODE_A;
break;
case CODE_CODE_C:
codeSet = CODE_CODE_C;
break;
case CODE_STOP:
done = true;
break;
}
}
break;
case CODE_CODE_C:
tmpResultSStr.str(std::string());
// the code read in this case is the number encoded directly
if (code < 100) {
if (code < 10) {
tmpResultSStr << '0';
}
tmpResultSStr << code;
tmpResultString.append(tmpResultSStr.str());
} else {
if (code != CODE_STOP) {
lastCharacterWasPrintable = false;
}
switch (code) {
case CODE_FNC_1:
// do nothing?
break;
case CODE_CODE_A:
codeSet = CODE_CODE_A;
break;
case CODE_CODE_B:
codeSet = CODE_CODE_B;
break;
case CODE_STOP:
done = true;
break;
}
}
break;
}
// Unshift back to another code set if we were shifted
if (unshift) {
switch (codeSet) {
case CODE_CODE_A:
codeSet = CODE_CODE_C;
break;
case CODE_CODE_B:
codeSet = CODE_CODE_A;
break;
case CODE_CODE_C:
codeSet = CODE_CODE_B;
break;
}
}
}
// Check for ample whitespace following pattern, but, to do this we first need to remember that
// we fudged decoding CODE_STOP since it actually has 7 bars, not 6. There is a black bar left
// to read off. Would be slightly better to properly read. Here we just skip it:
int width = row->getSize();
while (nextStart < width && row->get(nextStart)) {
nextStart++;
}
long minResult = 0;
#ifndef NOFMAXL
minResult = fminl(width, nextStart + (nextStart - lastStart)/ 2);
#else
minResult = fmin(width, nextStart + (nextStart - lastStart)/ 2);
#endif
if (!row->isRange(nextStart, minResult, false)) {
throw ReaderException("");
}
// Pull out from sum the value of the penultimate check code
checksumTotal -= multiplier * lastCode;
// lastCode is the checksum then:
if (checksumTotal % 103 != lastCode) {
throw ReaderException("");
}
// Need to pull out the check digits from string
int resultLength = tmpResultString.length();
// Only bother if the result had at least one character, and if the checksum digit happened to
// be a printable character. If it was just interpreted as a control code, nothing to remove.
if (resultLength > 0 && lastCharacterWasPrintable) {
if (codeSet == CODE_CODE_C) {
tmpResultString.erase(resultLength - 2, resultLength);
} else {
tmpResultString.erase(resultLength - 1, resultLength);
}
}
Ref<String> resultString(new String(tmpResultString));
if (tmpResultString.length() == 0) {
// Almost surely a false positive
throw ReaderException("");
}
float left = (float) (startPatternInfo[1] + startPatternInfo[0]) / 2.0f;
float right = (float) (nextStart + lastStart) / 2.0f;
std::vector< Ref<ResultPoint> > resultPoints(2);
Ref<OneDResultPoint> resultPoint1(new OneDResultPoint(left, (float) rowNumber));
Ref<OneDResultPoint> resultPoint2(new OneDResultPoint(right, (float) rowNumber));
resultPoints[0] = resultPoint1;
resultPoints[1] = resultPoint2;
delete [] startPatternInfo;
ArrayRef<unsigned char> resultBytes(1);
return Ref<Result>(new Result(resultString, resultBytes, resultPoints,
BarcodeFormat_CODE_128));
} catch (ReaderException const& re) {
delete [] startPatternInfo;
return Ref<Result>();
}
}
void RandomPCA::pca(MatrixXd &X, int method, bool transpose,
unsigned int ndim, unsigned int nextra, unsigned int maxiter, double tol,
long seed, int kernel, double sigma, bool rbf_center,
unsigned int rbf_sample, bool save_kernel, bool do_orth, bool do_loadings)
{
unsigned int N;
if(kernel != KERNEL_LINEAR)
{
transpose = false;
verbose && std::cout << timestamp()
<< " Kernel not linear, can't transpose" << std::endl;
}
verbose && std::cout << timestamp() << " Transpose: "
<< (transpose ? "yes" : "no") << std::endl;
if(transpose)
{
if(stand_method != STANDARDIZE_NONE)
X_meansd = standardize_transpose(X, stand_method, verbose);
N = X.cols();
}
else
{
if(stand_method != STANDARDIZE_NONE)
X_meansd = standardize(X, stand_method, verbose);
N = X.rows();
}
unsigned int total_dim = ndim + nextra;
MatrixXd R = make_gaussian(X.cols(), total_dim, seed);
MatrixXd Y = X * R;
verbose && std::cout << timestamp() << " dim(Y): " << dim(Y) << std::endl;
normalize(Y);
MatrixXd Yn;
verbose && std::cout << timestamp() << " dim(X): " << dim(X) << std::endl;
MatrixXd K;
if(kernel == KERNEL_RBF)
{
if(sigma == 0)
{
unsigned int med_samples = fminl(rbf_sample, N);
double med = median_dist(X, med_samples, seed, verbose);
sigma = sqrt(med);
}
verbose && std::cout << timestamp() << " Using RBF kernel with sigma="
<< sigma << std::endl;
K.noalias() = rbf_kernel(X, sigma, rbf_center, verbose);
}
else
{
verbose && std::cout << timestamp() << " Using linear kernel" << std::endl;
K.noalias() = X * X.transpose() / (N - 1);
}
//trace = K.diagonal().array().sum() / (N - 1);
trace = K.diagonal().array().sum();
verbose && std::cout << timestamp() << " Trace(K): " << trace
<< " (N: " << N << ")" << std::endl;
verbose && std::cout << timestamp() << " dim(K): " << dim(K) << std::endl;
if(save_kernel)
{
verbose && std::cout << timestamp() << " saving K" << std::endl;
save_text("kernel.txt", K);
}
for(unsigned int iter = 0 ; iter < maxiter ; iter++)
{
verbose && std::cout << timestamp() << " iter " << iter;
Yn.noalias() = K * Y;
if(do_orth)
{
verbose && std::cout << " (orthogonalising)";
ColPivHouseholderQR<MatrixXd> qr(Yn);
MatrixXd I = MatrixXd::Identity(Yn.rows(), Yn.cols());
Yn = qr.householderQ() * I;
Yn.conservativeResize(NoChange, Yn.cols());
}
else
normalize(Yn);
double diff = (Y - Yn).array().square().sum() / Y.size();
verbose && std::cout << " " << diff << std::endl;
Y.noalias() = Yn;
if(diff < tol)
break;
}
verbose && std::cout << timestamp() << " QR begin" << std::endl;
ColPivHouseholderQR<MatrixXd> qr(Y);
MatrixXd Q = MatrixXd::Identity(Y.rows(), Y.cols());
Q = qr.householderQ() * Q;
Q.conservativeResize(NoChange, Y.cols());
verbose && std::cout << timestamp() << " dim(Q): " << dim(Q) << std::endl;
verbose && std::cout << timestamp() << " QR done" << std::endl;
MatrixXd B = Q.transpose() * X;
verbose && std::cout << timestamp() << " dim(B): " << dim(B) << std::endl;
MatrixXd Et;
pca_small(B, method, Et, d, verbose);
verbose && std::cout << timestamp() << " dim(Et): " << dim(Et) << std::endl;
d = d.array() / (N - 1);
if(transpose)
{
V.noalias() = Q * Et;
// We divide P by sqrt(N - 1) since X has not been divided
// by it (but B has)
P.noalias() = X.transpose() * V;
VectorXd s = 1 / (d.array().sqrt() * sqrt(N - 1));
MatrixXd Dinv = s.asDiagonal();
U = P * Dinv;
}
else
{
// P = U D = X V
U.noalias() = Q * Et;
P.noalias() = U * d.asDiagonal();
if(do_loadings)
{
VectorXd s = 1 / (d.array().sqrt() * sqrt(N - 1));
MatrixXd Dinv = s.asDiagonal();
V = X.transpose() * U * Dinv;
}
}
P.conservativeResize(NoChange, ndim);
U.conservativeResize(NoChange, ndim);
V.conservativeResize(NoChange, ndim);
d.conservativeResize(ndim);
pve = d.array() / trace;
}
/* Subroutine */
int xdrre_(char *range, int *n, long double *vl,
long double *vu, int *il, int *iu, long double *d__, long double *e,
long double *e2, long double *rtol1, long double *rtol2, long double *spltol,
int *nsplit, int *isplit, int *m, long double *w,
long double *werr, long double *wgap, int *iblock, int *indexw,
long double *gers, long double *pivmin, long double *work, int *
iwork, int *info)
{
/* System generated locals */
int i__1, i__2;
long double d__1, d__2, d__3;
/* Builtin functions */
// long double sqrt(long double), log(long double);
/* Local variables */
int i__, j;
long double s1, s2;
int mb;
long double gl;
int in, mm;
long double gu;
int cnt;
long double eps, tau, tmp, rtl;
int cnt1, cnt2;
long double tmp1, eabs;
int iend, jblk;
long double eold;
int indl;
long double dmax__, emax;
int wend, idum, indu;
long double rtol;
int iseed[4];
long double avgap, sigma;
extern int xlsame_(char *, char *);
int iinfo;
extern /* Subroutine */ int xdcpy_(int *, long double *, int *,
long double *, int *);
long double norep;
extern /* Subroutine */ int xdsq2_(int *, long double *, int *);
// extern long double odmch_(char *);
int ibegin;
long double forceb;
int irange;
long double sgndef;
extern /* Subroutine */ int xdrra_(int *, long double *, long double *,
long double *, long double *, long double *, int *, int *,
int *), xdrrb_(int *, long double *, long double *,
int *, int *, long double *, long double *, int *,
long double *, long double *, long double *, long double *, int *,
long double *, long double *, int *, int *), xdrrc_(char *
, int *, long double *, long double *, long double *, long double
*, long double *, int *, int *, int *, int *);
int wbegin;
extern /* Subroutine */ int xdrrd_(char *, char *, int *, long double
*, long double *, int *, int *, long double *, long double *,
long double *, long double *, long double *, long double *, int *
, int *, int *, long double *, long double *, long double *,
long double *, int *, int *, long double *, int *,
int *);
long double safmin, spdiam;
extern /* Subroutine */ int xdrrk_(int *, int *, long double *,
long double *, long double *, long double *, long double *,
long double *, long double *, long double *, int *);
long double usedqd;
long double clwdth, isleft;
extern /* Subroutine */ int xdrnv_(int *, int *, int *,
long double *);
long double isrght, bsrtol, dpivot;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* To find the desired eigenvalues of a given real symmetric */
/* tridiagonal matrix T, XDRRE sets any "small" off-diagonal */
/* elements to zero, and for each unreduced block T_i, it finds */
/* (a) a suitable shift at one end of the block's spectrum, */
/* (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and */
/* (c) eigenvalues of each L_i D_i L_i^T. */
/* The representations and eigenvalues found are then used by */
/* DSTEMR to compute the eigenvectors of T. */
/* The accuracy varies depending on whether bisection is used to */
/* find a few eigenvalues or the dqds algorithm (subroutine XDSQ2) to */
/* conpute all and then discard any unwanted one. */
/* As an added benefit, XDRRE also outputs the n */
/* Gerschgorin intervals for the matrices L_i D_i L_i^T. */
/* Arguments */
/* ========= */
/* RANGE (input) CHARACTER */
/* = 'A': ("All") all eigenvalues will be found. */
/* = 'V': ("Value") all eigenvalues in the half-open interval */
/* (VL, VU] will be found. */
/* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */
/* entire matrix) will be found. */
/* N (input) INT */
/* The order of the matrix. N > 0. */
/* VL (input/output) LONG DOUBLE PRECISION */
/* VU (input/output) LONG DOUBLE PRECISION */
/* If RANGE='V', the lower and upper bounds for the eigenvalues. */
/* Eigenvalues less than or equal to VL, or greater than VU, */
/* will not be returned. VL < VU. */
/* If RANGE='I' or ='A', XDRRE computes bounds on the desired */
/* part of the spectrum. */
/* IL (input) INT */
/* IU (input) INT */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N. */
/* D (input/output) LONG DOUBLE PRECISION array, dimension (N) */
/* On entry, the N diagonal elements of the tridiagonal */
/* matrix T. */
/* On exit, the N diagonal elements of the diagonal */
/* matrices D_i. */
/* E (input/output) LONG DOUBLE PRECISION array, dimension (N) */
/* On entry, the first (N-1) entries contain the subdiagonal */
/* elements of the tridiagonal matrix T; E(N) need not be set. */
/* On exit, E contains the subdiagonal elements of the unit */
/* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ), */
/* 1 <= I <= NSPLIT, contain the base points sigma_i on output. */
/* E2 (input/output) LONG DOUBLE PRECISION array, dimension (N) */
/* On entry, the first (N-1) entries contain the SQUARES of the */
/* subdiagonal elements of the tridiagonal matrix T; */
/* E2(N) need not be set. */
/* On exit, the entries E2( ISPLIT( I ) ), */
/* 1 <= I <= NSPLIT, have been set to zero */
/* RTOL1 (input) LONG DOUBLE PRECISION */
/* RTOL2 (input) LONG DOUBLE PRECISION */
/* Parameters for bisection. */
/* An interval [LEFT,RIGHT] has converged if */
/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */
/* SPLTOL (input) LONG DOUBLE PRECISION */
/* The threshold for splitting. */
/* NSPLIT (output) INT */
/* The number of blocks T splits into. 1 <= NSPLIT <= N. */
/* ISPLIT (output) INT array, dimension (N) */
/* The splitting points, at which T breaks up into blocks. */
/* The first block consists of rows/columns 1 to ISPLIT(1), */
/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */
/* etc., and the NSPLIT-th consists of rows/columns */
/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */
/* M (output) INT */
/* The total number of eigenvalues (of all L_i D_i L_i^T) */
/* found. */
/* W (output) LONG DOUBLE PRECISION array, dimension (N) */
/* The first M elements contain the eigenvalues. The */
/* eigenvalues of each of the blocks, L_i D_i L_i^T, are */
/* sorted in ascending order ( XDRRE may use the */
/* remaining N-M elements as workspace). */
/* WERR (output) LONG DOUBLE PRECISION array, dimension (N) */
/* The error bound on the corresponding eigenvalue in W. */
/* WGAP (output) LONG DOUBLE PRECISION array, dimension (N) */
/* The separation from the right neighbor eigenvalue in W. */
/* The gap is only with respect to the eigenvalues of the same block */
/* as each block has its own representation tree. */
/* Exception: at the right end of a block we store the left gap */
/* IBLOCK (output) INT array, dimension (N) */
/* The indices of the blocks (submatrices) associated with the */
/* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */
/* W(i) belongs to the first block from the top, =2 if W(i) */
/* belongs to the second block, etc. */
/* INDEXW (output) INT array, dimension (N) */
/* The indices of the eigenvalues within each block (submatrix); */
/* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */
/* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2 */
/* GERS (output) LONG DOUBLE PRECISION array, dimension (2*N) */
/* The N Gerschgorin intervals (the i-th Gerschgorin interval */
/* is (GERS(2*i-1), GERS(2*i)). */
/* PIVMIN (output) LONG DOUBLE PRECISION */
/* The minimum pivot in the Sturm sequence for T. */
/* WORK (workspace) LONG DOUBLE PRECISION array, dimension (6*N) */
/* Workspace. */
/* IWORK (workspace) INT array, dimension (5*N) */
/* Workspace. */
/* INFO (output) INT */
/* = 0: successful exit */
/* > 0: A problem occured in XDRRE. */
/* < 0: One of the called subroutines signaled an internal problem. */
/* Needs inspection of the corresponding parameter IINFO */
/* for further information. */
/* =-1: Problem in XDRRD. */
/* = 2: No base representation could be found in MAXTRY iterations. */
/* Increasing MAXTRY and recompilation might be a remedy. */
/* =-3: Problem in XDRRB when computing the refined root */
/* representation for XDSQ2. */
/* =-4: Problem in XDRRB when preforming bisection on the */
/* desired part of the spectrum. */
/* =-5: Problem in XDSQ2. */
/* =-6: Problem in XDSQ2. */
/* Further Details */
/* The base representations are required to suffer very little */
/* element growth and consequently define all their eigenvalues to */
/* high relative accuracy. */
/* =============== */
/* Based on contributions by */
/* Beresford Parlett, University of California, Berkeley, USA */
/* Jim Demmel, University of California, Berkeley, USA */
/* Inderjit Dhillon, University of Texas, Austin, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* Christof Voemel, University of California, Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--iwork;
--work;
--gers;
--indexw;
--iblock;
--wgap;
--werr;
--w;
--isplit;
--e2;
--e;
--d__;
/* Function Body */
*info = 0;
/* Decode RANGE */
if (xlsame_(range, "A")) {
irange = 1;
} else if (xlsame_(range, "V")) {
irange = 3;
} else if (xlsame_(range, "I")) {
irange = 2;
}
*m = 0;
/* Get machine constants */
safmin = LDBL_MIN; // odmch_("S");
eps = LDBL_EPSILON; // odmch_("P");
/* Set parameters */
rtl = sqrt(eps);
bsrtol = sqrt(eps);
/* Treat case of 1x1 matrix for quick return */
if (*n == 1) {
if (irange == 1 || irange == 3 && d__[1] > *vl && d__[1] <= *vu ||
irange == 2 && *il == 1 && *iu == 1) {
*m = 1;
w[1] = d__[1];
/* The computation error of the eigenvalue is zero */
werr[1] = 0.;
wgap[1] = 0.;
iblock[1] = 1;
indexw[1] = 1;
gers[1] = d__[1];
gers[2] = d__[1];
}
/* store the shift for the initial RRR, which is zero in this case */
e[1] = 0.;
return 0;
}
/* General case: tridiagonal matrix of order > 1 */
/* Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter. */
/* Compute maximum off-diagonal entry and pivmin. */
gl = d__[1];
gu = d__[1];
eold = 0.;
emax = 0.;
e[*n] = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
werr[i__] = 0.;
wgap[i__] = 0.;
eabs = (d__1 = e[i__], fabsl(d__1));
if (eabs >= emax) {
emax = eabs;
}
tmp1 = eabs + eold;
gers[(i__ << 1) - 1] = d__[i__] - tmp1;
/* Computing MIN */
d__1 = gl, d__2 = gers[(i__ << 1) - 1];
gl = fminl(d__1,d__2);
gers[i__ * 2] = d__[i__] + tmp1;
/* Computing MAX */
d__1 = gu, d__2 = gers[i__ * 2];
gu = fmaxl(d__1,d__2);
eold = eabs;
/* L5: */
}
/* The minimum pivot allowed in the Sturm sequence for T */
/* Computing MAX */
/* Computing 2nd power */
d__3 = emax;
d__1 = 1., d__2 = d__3 * d__3;
*pivmin = safmin * fmaxl(d__1,d__2);
/* Compute spectral diameter. The Gerschgorin bounds give an */
/* estimate that is wrong by at most a factor of SQRT(2) */
spdiam = gu - gl;
/* Compute splitting points */
xdrra_(n, &d__[1], &e[1], &e2[1], spltol, &spdiam, nsplit, &isplit[1], &
iinfo);
/* Can force use of bisection instead of faster DQDS. */
/* Option left in the code for future multisection work. */
forceb = FALSE_;
/* Initialize USEDQD, DQDS should be used for ALLRNG unless someone */
/* explicitly wants bisection. */
usedqd = irange == 1 && ! forceb;
if (irange == 1 && ! forceb) {
/* Set interval [VL,VU] that contains all eigenvalues */
*vl = gl;
*vu = gu;
} else {
/* We call XDRRD to find crude approximations to the eigenvalues */
/* in the desired range. In case IRANGE = INDRNG, we also obtain the */
/* interval (VL,VU] that contains all the wanted eigenvalues. */
/* An interval [LEFT,RIGHT] has converged if */
/* RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT)) */
/* XDRRD needs a WORK of size 4*N, IWORK of size 3*N */
xdrrd_(range, "B", n, vl, vu, il, iu, &gers[1], &bsrtol, &d__[1], &e[
1], &e2[1], pivmin, nsplit, &isplit[1], &mm, &w[1], &werr[1],
vl, vu, &iblock[1], &indexw[1], &work[1], &iwork[1], &iinfo);
if (iinfo != 0) {
*info = -1;
return 0;
}
/* Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0 */
i__1 = *n;
for (i__ = mm + 1; i__ <= i__1; ++i__) {
w[i__] = 0.;
werr[i__] = 0.;
iblock[i__] = 0;
indexw[i__] = 0;
/* L14: */
}
}
/* ** */
/* Loop over unreduced blocks */
ibegin = 1;
wbegin = 1;
i__1 = *nsplit;
for (jblk = 1; jblk <= i__1; ++jblk) {
iend = isplit[jblk];
in = iend - ibegin + 1;
/* 1 X 1 block */
if (in == 1) {
if (irange == 1 || irange == 3 && d__[ibegin] > *vl && d__[ibegin]
<= *vu || irange == 2 && iblock[wbegin] == jblk) {
++(*m);
w[*m] = d__[ibegin];
werr[*m] = 0.;
/* The gap for a single block doesn't matter for the later */
/* algorithm and is assigned an arbitrary large value */
wgap[*m] = 0.;
iblock[*m] = jblk;
indexw[*m] = 1;
++wbegin;
}
/* E( IEND ) holds the shift for the initial RRR */
e[iend] = 0.;
ibegin = iend + 1;
goto L170;
}
/* Blocks of size larger than 1x1 */
/* E( IEND ) will hold the shift for the initial RRR, for now set it =0 */
e[iend] = 0.;
/* Find local outer bounds GL,GU for the block */
gl = d__[ibegin];
gu = d__[ibegin];
i__2 = iend;
for (i__ = ibegin; i__ <= i__2; ++i__) {
/* Computing MIN */
d__1 = gers[(i__ << 1) - 1];
gl = fminl(d__1,gl);
/* Computing MAX */
d__1 = gers[i__ * 2];
gu = fmaxl(d__1,gu);
/* L15: */
}
spdiam = gu - gl;
if (! (irange == 1 && ! forceb)) {
/* Count the number of eigenvalues in the current block. */
mb = 0;
i__2 = mm;
for (i__ = wbegin; i__ <= i__2; ++i__) {
if (iblock[i__] == jblk) {
++mb;
} else {
goto L21;
}
/* L20: */
}
L21:
if (mb == 0) {
/* No eigenvalue in the current block lies in the desired range */
/* E( IEND ) holds the shift for the initial RRR */
e[iend] = 0.;
ibegin = iend + 1;
goto L170;
} else {
/* Decide whether dqds or bisection is more efficient */
usedqd = (long double) mb > in * .5 && ! forceb;
wend = wbegin + mb - 1;
/* Calculate gaps for the current block */
/* In later stages, when representations for individual */
/* eigenvalues are different, we use SIGMA = E( IEND ). */
sigma = 0.;
i__2 = wend - 1;
for (i__ = wbegin; i__ <= i__2; ++i__) {
/* Computing MAX */
d__1 = 0., d__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] +
werr[i__]);
wgap[i__] = fmaxl(d__1,d__2);
/* L30: */
}
/* Computing MAX */
d__1 = 0., d__2 = *vu - sigma - (w[wend] + werr[wend]);
wgap[wend] = fmaxl(d__1,d__2);
/* Find local index of the first and last desired evalue. */
indl = indexw[wbegin];
indu = indexw[wend];
}
}
if (irange == 1 && ! forceb || usedqd) {
/* Case of DQDS */
/* Find approximations to the extremal eigenvalues of the block */
xdrrk_(&in, &c__1, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, &
rtl, &tmp, &tmp1, &iinfo);
if (iinfo != 0) {
*info = -1;
return 0;
}
/* Computing MAX */
d__2 = gl, d__3 = tmp - tmp1 - eps * 100. * (d__1 = tmp - tmp1,
fabsl(d__1));
isleft = fmaxl(d__2,d__3);
xdrrk_(&in, &in, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, &
rtl, &tmp, &tmp1, &iinfo);
if (iinfo != 0) {
*info = -1;
return 0;
}
/* Computing MIN */
d__2 = gu, d__3 = tmp + tmp1 + eps * 100. * (d__1 = tmp + tmp1,
fabsl(d__1));
isrght = fminl(d__2,d__3);
/* Improve the estimate of the spectral diameter */
spdiam = isrght - isleft;
} else {
/* Case of bisection */
/* Find approximations to the wanted extremal eigenvalues */
/* Computing MAX */
d__2 = gl, d__3 = w[wbegin] - werr[wbegin] - eps * 100. * (d__1 =
w[wbegin] - werr[wbegin], fabsl(d__1));
isleft = fmaxl(d__2,d__3);
/* Computing MIN */
d__2 = gu, d__3 = w[wend] + werr[wend] + eps * 100. * (d__1 = w[
wend] + werr[wend], fabsl(d__1));
isrght = fminl(d__2,d__3);
}
/* Decide whether the base representation for the current block */
/* L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I */
/* should be on the left or the right end of the current block. */
/* The strategy is to shift to the end which is "more populated" */
/* Furthermore, decide whether to use DQDS for the computation of */
/* the eigenvalue approximations at the end of XDRRE or bisection. */
/* dqds is chosen if all eigenvalues are desired or the number of */
/* eigenvalues to be computed is large compared to the blocksize. */
if (irange == 1 && ! forceb) {
/* If all the eigenvalues have to be computed, we use dqd */
usedqd = TRUE_;
/* INDL is the local index of the first eigenvalue to compute */
indl = 1;
indu = in;
/* MB = number of eigenvalues to compute */
mb = in;
wend = wbegin + mb - 1;
/* Define 1/4 and 3/4 points of the spectrum */
s1 = isleft + spdiam * .25;
s2 = isrght - spdiam * .25;
} else {
/* XDRRD has computed IBLOCK and INDEXW for each eigenvalue */
/* approximation. */
/* choose sigma */
if (usedqd) {
s1 = isleft + spdiam * .25;
s2 = isrght - spdiam * .25;
} else {
tmp = fminl(isrght,*vu) - fmaxl(isleft,*vl);
s1 = fmaxl(isleft,*vl) + tmp * .25;
s2 = fminl(isrght,*vu) - tmp * .25;
}
}
/* Compute the negcount at the 1/4 and 3/4 points */
if (mb > 1) {
xdrrc_("T", &in, &s1, &s2, &d__[ibegin], &e[ibegin], pivmin, &
cnt, &cnt1, &cnt2, &iinfo);
}
if (mb == 1) {
sigma = gl;
sgndef = 1.;
} else if (cnt1 - indl >= indu - cnt2) {
if (irange == 1 && ! forceb) {
sigma = fmaxl(isleft,gl);
} else if (usedqd) {
/* use Gerschgorin bound as shift to get pos def matrix */
/* for dqds */
sigma = isleft;
} else {
/* use approximation of the first desired eigenvalue of the */
/* block as shift */
sigma = fmaxl(isleft,*vl);
}
sgndef = 1.;
} else {
if (irange == 1 && ! forceb) {
sigma = fminl(isrght,gu);
} else if (usedqd) {
/* use Gerschgorin bound as shift to get neg def matrix */
/* for dqds */
sigma = isrght;
} else {
/* use approximation of the first desired eigenvalue of the */
/* block as shift */
sigma = fminl(isrght,*vu);
}
sgndef = -1.;
}
/* An initial SIGMA has been chosen that will be used for computing */
/* T - SIGMA I = L D L^T */
/* Define the increment TAU of the shift in case the initial shift */
/* needs to be refined to obtain a factorization with not too much */
/* element growth. */
if (usedqd) {
/* The initial SIGMA was to the outer end of the spectrum */
/* the matrix is definite and we need not retreat. */
tau = spdiam * eps * *n + *pivmin * 2.;
tau = fmaxl(tau, 2 * eps * fabsl(sigma));
} else {
if (mb > 1) {
clwdth = w[wend] + werr[wend] - w[wbegin] - werr[wbegin];
avgap = (d__1 = clwdth / (long double) (wend - wbegin), fabsl(
d__1));
if (sgndef == 1.) {
/* Computing MAX */
d__1 = wgap[wbegin];
tau = fmaxl(d__1,avgap) * .5;
/* Computing MAX */
d__1 = tau, d__2 = werr[wbegin];
tau = fmaxl(d__1,d__2);
} else {
/* Computing MAX */
d__1 = wgap[wend - 1];
tau = fmaxl(d__1,avgap) * .5;
/* Computing MAX */
d__1 = tau, d__2 = werr[wend];
tau = fmaxl(d__1,d__2);
}
} else {
tau = werr[wbegin];
}
}
for (idum = 1; idum <= 6; ++idum) {
/* Compute L D L^T factorization of tridiagonal matrix T - sigma I. */
/* Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of */
/* pivots in WORK(2*IN+1:3*IN) */
dpivot = d__[ibegin] - sigma;
work[1] = dpivot;
dmax__ = fabsl(work[1]);
j = ibegin;
i__2 = in - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[(in << 1) + i__] = 1. / work[i__];
tmp = e[j] * work[(in << 1) + i__];
work[in + i__] = tmp;
dpivot = d__[j + 1] - sigma - tmp * e[j];
work[i__ + 1] = dpivot;
/* Computing MAX */
d__1 = dmax__, d__2 = fabsl(dpivot);
dmax__ = fmaxl(d__1,d__2);
++j;
/* L70: */
}
/* check for element growth */
if (dmax__ > spdiam * 64.) {
norep = TRUE_;
} else {
norep = FALSE_;
}
if (usedqd && ! norep) {
/* Ensure the definiteness of the representation */
/* All entries of D (of L D L^T) must have the same sign */
i__2 = in;
for (i__ = 1; i__ <= i__2; ++i__) {
tmp = sgndef * work[i__];
if (tmp < 0.) {
norep = TRUE_;
}
/* L71: */
}
}
if (norep) {
/* Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin */
/* shift which makes the matrix definite. So we should end up */
/* here really only in the case of IRANGE = VALRNG or INDRNG. */
if (idum == 5) {
if (sgndef == 1.) {
/* The fudged Gerschgorin shift should succeed */
sigma = gl - spdiam * 2. * eps * *n - *pivmin * 4.;
} else {
sigma = gu + spdiam * 2. * eps * *n + *pivmin * 4.;
}
} else {
sigma -= sgndef * tau;
tau *= 2.;
}
} else {
/* an initial RRR is found */
goto L83;
}
/* L80: */
}
/* if the program reaches this point, no base representation could be */
/* found in MAXTRY iterations. */
*info = 2;
return 0;
L83:
/* At this point, we have found an initial base representation */
/* T - SIGMA I = L D L^T with not too much element growth. */
/* Store the shift. */
e[iend] = sigma;
/* Store D and L. */
xdcpy_(&in, &work[1], &c__1, &d__[ibegin], &c__1);
i__2 = in - 1;
xdcpy_(&i__2, &work[in + 1], &c__1, &e[ibegin], &c__1);
if (mb > 1) {
/* Perturb each entry of the base representation by a small */
/* (but random) relative amount to overcome difficulties with */
/* glued matrices. */
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = 1;
/* L122: */
}
i__2 = (in << 1) - 1;
xdrnv_(&c__2, iseed, &i__2, &work[1]);
i__2 = in - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
d__[ibegin + i__ - 1] *= eps * 8. * work[i__] + 1.;
e[ibegin + i__ - 1] *= eps * 8. * work[in + i__] + 1.;
/* L125: */
}
d__[iend] *= eps * 4. * work[in] + 1.;
}
/* Don't update the Gerschgorin intervals because keeping track */
/* of the updates would be too much work in DLARRV. */
/* We update W instead and use it to locate the proper Gerschgorin */
/* intervals. */
/* Compute the required eigenvalues of L D L' by bisection or dqds */
if (! usedqd) {
/* If XDRRD has been used, shift the eigenvalue approximations */
/* according to their representation. This is necessary for */
/* a uniform DLARRV since dqds computes eigenvalues of the */
/* shifted representation. In DLARRV, W will always hold the */
/* UNshifted eigenvalue approximation. */
i__2 = wend;
for (j = wbegin; j <= i__2; ++j) {
w[j] -= sigma;
werr[j] += (d__1 = w[j], fabsl(d__1)) * eps;
/* L134: */
}
/* call XDRRB to reduce eigenvalue error of the approximations */
/* from XDRRD */
i__2 = iend - 1;
for (i__ = ibegin; i__ <= i__2; ++i__) {
/* Computing 2nd power */
d__1 = e[i__];
work[i__] = d__[i__] * (d__1 * d__1);
/* L135: */
}
/* use bisection to find EV from INDL to INDU */
i__2 = indl - 1;
xdrrb_(&in, &d__[ibegin], &work[ibegin], &indl, &indu, rtol1,
rtol2, &i__2, &w[wbegin], &wgap[wbegin], &werr[wbegin], &
work[(*n << 1) + 1], &iwork[1], pivmin, &spdiam, &in, &
iinfo);
if (iinfo != 0) {
*info = -4;
return 0;
}
/* XDRRB computes all gaps correctly except for the last one */
/* Record distance to VU/GU */
/* Computing MAX */
d__1 = 0., d__2 = *vu - sigma - (w[wend] + werr[wend]);
wgap[wend] = fmaxl(d__1,d__2);
i__2 = indu;
for (i__ = indl; i__ <= i__2; ++i__) {
++(*m);
iblock[*m] = jblk;
indexw[*m] = i__;
/* L138: */
}
} else {
/* Call dqds to get all eigs (and then possibly delete unwanted */
/* eigenvalues). */
/* Note that dqds finds the eigenvalues of the L D L^T representation */
/* of T to high relative accuracy. High relative accuracy */
/* might be lost when the shift of the RRR is subtracted to obtain */
/* the eigenvalues of T. However, T is not guaranteed to define its */
/* eigenvalues to high relative accuracy anyway. */
/* Set RTOL to the order of the tolerance used in XDSQ2 */
/* This is an ESTIMATED error, the worst case bound is 4*N*EPS */
/* which is usually too large and requires unnecessary work to be */
/* done by bisection when computing the eigenvectors */
rtol = log((long double) in) * 4. * eps;
j = ibegin;
i__2 = in - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[(i__ << 1) - 1] = (d__1 = d__[j], fabsl(d__1));
work[i__ * 2] = e[j] * e[j] * work[(i__ << 1) - 1];
++j;
/* L140: */
}
work[(in << 1) - 1] = (d__1 = d__[iend], fabsl(d__1));
work[in * 2] = 0.;
xdsq2_(&in, &work[1], &iinfo);
if (iinfo != 0) {
/* If IINFO = -5 then an index is part of a tight cluster */
/* and should be changed. The index is in IWORK(1) and the */
/* gap is in WORK(N+1) */
*info = -5;
return 0;
} else {
/* Test that all eigenvalues are positive as expected */
i__2 = in;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] < 0.) {
*info = -6;
return 0;
}
/* L149: */
}
}
if (sgndef > 0.) {
i__2 = indu;
for (i__ = indl; i__ <= i__2; ++i__) {
++(*m);
w[*m] = work[in - i__ + 1];
iblock[*m] = jblk;
indexw[*m] = i__;
/* L150: */
}
} else {
i__2 = indu;
for (i__ = indl; i__ <= i__2; ++i__) {
++(*m);
w[*m] = -work[i__];
iblock[*m] = jblk;
indexw[*m] = i__;
/* L160: */
}
}
i__2 = *m;
for (i__ = *m - mb + 1; i__ <= i__2; ++i__) {
/* the value of RTOL below should be the tolerance in XDSQ2 */
werr[i__] = rtol * (d__1 = w[i__], fabsl(d__1));
/* L165: */
}
i__2 = *m - 1;
for (i__ = *m - mb + 1; i__ <= i__2; ++i__) {
/* compute the right gap between the intervals */
/* Computing MAX */
d__1 = 0., d__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] + werr[
i__]);
wgap[i__] = fmaxl(d__1,d__2);
/* L166: */
}
/* Computing MAX */
d__1 = 0., d__2 = *vu - sigma - (w[*m] + werr[*m]);
wgap[*m] = fmaxl(d__1,d__2);
}
/* proceed with next block */
ibegin = iend + 1;
wbegin = wend + 1;
L170:
;
}
return 0;
/* end of XDRRE */
} /* xdrre_ */
/* Subroutine */
int xdsq6_(int *i0, int *n0, long double *z__,
int *pp, long double *dmin__, long double *dmin1, long double *dmin2,
long double *dn, long double *dnm1, long double *dnm2)
{
/* System generated locals */
int i__1;
long double d__1, d__2;
/* Local variables */
long double d__;
int j4, j4p2;
long double emin, temp;
// extern long double odmch_(char *);
long double safmin;
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
/* -- Berkeley -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* XDSQ6 computes one dqd (shift equal to zero) transform in */
/* ping-pong form, with protection against underflow and overflow. */
/* Arguments */
/* ========= */
/* I0 (input) INT */
/* First index. */
/* N0 (input) INT */
/* Last index. */
/* Z (input) LONG DOUBLE PRECISION array, dimension ( 4*N ) */
/* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid */
/* an extra argument. */
/* PP (input) INT */
/* PP=0 for ping, PP=1 for pong. */
/* DMIN (output) LONG DOUBLE PRECISION */
/* Minimum value of d. */
/* DMIN1 (output) LONG DOUBLE PRECISION */
/* Minimum value of d, excluding D( N0 ). */
/* DMIN2 (output) LONG DOUBLE PRECISION */
/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */
/* DN (output) LONG DOUBLE PRECISION */
/* d(N0), the last value of d. */
/* DNM1 (output) LONG DOUBLE PRECISION */
/* d(N0-1). */
/* DNM2 (output) LONG DOUBLE PRECISION */
/* d(N0-2). */
/* ===================================================================== */
/* .. Parameter .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Function .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--z__;
/* Function Body */
if (*n0 - *i0 - 1 <= 0) {
return 0;
}
safmin = LDBL_MIN; // odmch_("Safe minimum");
j4 = (*i0 << 2) + *pp - 3;
emin = z__[j4 + 4];
d__ = z__[j4];
*dmin__ = d__;
if (*pp == 0) {
i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 2] = d__ + z__[j4 - 1];
if (z__[j4 - 2] == 0.) {
z__[j4] = 0.;
d__ = z__[j4 + 1];
*dmin__ = d__;
emin = 0.;
} else if (safmin * z__[j4 + 1] < z__[j4 - 2] && safmin * z__[j4
- 2] < z__[j4 + 1]) {
temp = z__[j4 + 1] / z__[j4 - 2];
z__[j4] = z__[j4 - 1] * temp;
d__ *= temp;
} else {
z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]);
d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]);
}
*dmin__ = fminl(*dmin__,d__);
/* Computing MIN */
d__1 = emin, d__2 = z__[j4];
emin = fminl(d__1,d__2);
/* L10: */
}
} else {
i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 3] = d__ + z__[j4];
if (z__[j4 - 3] == 0.) {
z__[j4 - 1] = 0.;
d__ = z__[j4 + 2];
*dmin__ = d__;
emin = 0.;
} else if (safmin * z__[j4 + 2] < z__[j4 - 3] && safmin * z__[j4
- 3] < z__[j4 + 2]) {
temp = z__[j4 + 2] / z__[j4 - 3];
z__[j4 - 1] = z__[j4] * temp;
d__ *= temp;
} else {
z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]);
d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]);
}
*dmin__ = fminl(*dmin__,d__);
/* Computing MIN */
d__1 = emin, d__2 = z__[j4 - 1];
emin = fminl(d__1,d__2);
/* L20: */
}
}
/* Unroll last two steps. */
*dnm2 = d__;
*dmin2 = *dmin__;
j4 = (*n0 - 2 << 2) - *pp;
j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm2 + z__[j4p2];
if (z__[j4 - 2] == 0.) {
z__[j4] = 0.;
*dnm1 = z__[j4p2 + 2];
*dmin__ = *dnm1;
emin = 0.;
} else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] <
z__[j4p2 + 2]) {
temp = z__[j4p2 + 2] / z__[j4 - 2];
z__[j4] = z__[j4p2] * temp;
*dnm1 = *dnm2 * temp;
} else {
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]);
}
*dmin__ = fminl(*dmin__,*dnm1);
*dmin1 = *dmin__;
j4 += 4;
j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm1 + z__[j4p2];
if (z__[j4 - 2] == 0.) {
z__[j4] = 0.;
*dn = z__[j4p2 + 2];
*dmin__ = *dn;
emin = 0.;
} else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] <
z__[j4p2 + 2]) {
temp = z__[j4p2 + 2] / z__[j4 - 2];
z__[j4] = z__[j4p2] * temp;
*dn = *dnm1 * temp;
} else {
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]);
}
*dmin__ = fminl(*dmin__,*dn);
z__[j4 + 2] = *dn;
z__[(*n0 << 2) - *pp] = emin;
return 0;
/* End of XDSQ6 */
} /* xdsq6_ */
TEST(math, fminl) {
ASSERT_DOUBLE_EQ(10.0L, fminl(12.0L, 10.0L));
ASSERT_DOUBLE_EQ(12.0L, fminl(12.0L, nanl("")));
ASSERT_DOUBLE_EQ(12.0L, fminl(nanl(""), 12.0L));
}
int main() {
/*
# Math errors
# Errors
The following errors exist for the standard library functions.
# Domain error
Value outside of function domain. E.g.: `sqrt(-1.0)`.
TODO undefined or implementation defined?
Detection: if `math_errhandling & MATH_ERRNO != 0`, `errno = ERANGE`
and a "divide-by-zero" floating point exception is raised.
# Pole error
Function has a pole at a point. Ex: `log(0.0)`, `tgamma(-1.0)`.
Return value: HUGE_VAL.
Detection if `math_errhandling & MATH_ERRNO != 0`, `errno = ERANGE`
and a "divide-by-zero" floating point exception is raised.
# Range errors
Occur if the result is too large or too small to fint into the return type.
There are two types of range errors overflow and underflow.
In both cases, if `math_errhandling & MATH_ERRNO != 0`,
`errno = ERANGE` and a "divide-by-zero" floating point exception is raised.
# Overflow
For exapmle, around poles, functions can have arbitrarily large values,
so it is possible that for a given input close enough to the pole that the output is too large to reprent.
Return value: HUGE_VAL, HUGE_VALF, or HUGE_VALL, acording to function's return type.
# Underflow
The output is too small to represent
Return value: an implementation-defined value whose magnitude is no greater than the smallest
normalized positive number in the specified type;
*/
printf("math_errhandling & MATH_ERRNO = %d\n", math_errhandling & MATH_ERRNO);
/*
# fabs
Floating point abs.
Integer version is in stdlib
*/
{
/* Absolute values, float version: */
assert(fabsl(-1.1) == 1.1);
}
#if __STDC_VERSION__ >= 199901L
/*
# fminl
# fmaxl
Max and min for floats.
*/
{
assert(fminl(0.1, 0.2) == 0.1);
assert(fmaxl(0.1, 0.2) == 0.2);
}
#endif
/*
# Rounding
*/
{
/*
# floor
# ceil
*/
{
assert(fabs(floor(0.5) - 0.0) < ERR);
assert(fabs(ceil(0.5) - 1.0) < ERR);
}
/*
# trunc
Never raises any errors because the new result always fits in the data type (magnitide decresases).
*/
{
assert(fabs(trunc(1.5) - 1.0) < ERR);
assert(fabs(trunc(-1.5) - -1.0) < ERR);
}
/*
# round
Away from 0 on mid case.
*/
{
assert(fabs(round( 1.25) - 1.0) < ERR);
assert(fabs(round( 1.5 ) - 2.0) < ERR);
assert(fabs(round( 1.75) - 2.0) < ERR);
assert(fabs(round(-1.5 ) - -2.0) < ERR);
}
/*
# modf
Decompose into fraction and integer parts.
*/
{
double d;
assert(fabs(modf(12.34, &d) - 0.34) < ERR);
assert(fabs(d - 12.0 ) < ERR);
}
/*
# frexp
Decompose into:
- integer exponent
- normalized mantissa, a fraction between 0.5 (inclusive) and 1.0 (exclusive)
Guaranteed to power of 2 representation,
even though this is not true for floating point?
E.g. FLT_RADIX macros indicate it.
*/
{
int i;
/* 1.5 = 0.75 * 2^1 */
assert(frexp(1.5, &i) == 0.75);
assert(i == 1);
/* 3.0 = 0.75 * 2^2 */
assert(frexp(3.0, &i) == 0.75);
assert(i == 2);
}
}
/*
# fma
Fused multiple add or floating point multiply and add.
Does addition and multiplication on one operation,
with a single rounding, reduncing rounding errors.
Has hardware implementations on certain platforms.
*/
{
assert(fabs(fma(2.0, 3.0, 4.0) - (2.0 * 3.0 + 4.0)) < ERR);
}
/* # Exponential functions */
{
/* # exp */
{
assert(fabs(exp(1.0) - 2.71) < 0.01);
}
/*
# ln
See log.
# log
Calculates the ln.
*/
{
assert(fabs(log(exp(1.0)) - 1.0) < ERR);
assert(fabs(log2(8.0) - 3.0) < ERR);
assert(fabs(log10(100.0) - 2.0) < ERR);
}
/*
# sqrt
Range is positive or zero. Negatives are a range error.
To get complex on negative values, use `csqrt`.
*/
{
assert(fabs(sqrt(4.0) - 2.0) < ERR);
/* GCC 4.7 -O3 is smart enough to see that this is bad: */
{
float f = -4.0;
/*printf("sqrt(-4.0) = %f\n", sqrt(f));*/
}
{
float f;
volatile float g;
f = -4.0;
errno = 0;
g = sqrt(f);
if (math_errhandling & MATH_ERRNO)
assert(errno == EDOM);
printf("sqrt(-4.0) = %f\n", f);
}
}
#if __STDC_VERSION__ >= 199901L
/*
# hypot
Hypotenuse: sqrt(x^2 + y^2)
*/
{
assert(fabs(hypot(3.0, 4.0) - 5.0) < ERR);
}
#endif
#if __STDC_VERSION__ >= 199901L
/*
# cbrt
CuBe RooT
*/
{
assert(fabs(cbrt(8.0 ) - 2.0) < ERR);
assert(fabs(cbrt(-8.0) - -2.0) < ERR);
}
#endif
/* # pow */
{
assert(fabs(pow(2.0, 3.0) - 8.0 ) < ERR);
}
}
/* # trig */
{
float f = sin(0.2);
assert(fabs(sin(0.0) - 0.0) < ERR);
assert(fabs(cos(0.0) - 1.0) < ERR);
/*
# PI
There is no predefined macro for PI. TODO0 why not? so convenient...
This is a standard way to get PI.
The only problem is a possible slight calculation overhead.
But don't worry much about it. For example in gcc 4.7, even with `gcc -O0` trigonometric functions
are calculated at compile time and stored in the program text.
*/
{
assert(fabs(acos(-1.0) - 3.14) < 0.01);
}
}
/* # erf: TODO0 understand */
/*
# factorial
There seems to be no integer factorial function,
but `gamma(n+1)` coincides with the factorials of `n` on the positive integers,
and may be faster to compute via analytic approximations that can be done to gamma
and/or via a hardware implementation, so just use gamma.
# gamma
Wiki link: <http://en.wikipedia.org/wiki/Gamma_function>
Extension of the factorials to the real numbers because:
- on the positive integergs:
gamma(n+1) == n!
- on the positive reals:
gamma(x+1) == x * gamma(x)
Has a holomorphic continuation to all imaginary plane, with poles on 0 and negative integers.
Implemented in C as `tgamma`.
# tgamma
True Gamma function. TODO0 Why True?
Computes the gamma function.
ANSI C says that it gives either domain or pole error on the negative integers.
# lgamma
lgamma = ln tgamma
*/
{
assert(fabs(tgamma(5.0) - 4*3*2) < ERR);
assert(fabs(tgamma(3.5) - 2.5*tgamma(2.5)) < ERR);
errno = 0;
volatile double d = tgamma(-1.0);
if (math_errhandling & MATH_ERRNO) {
if (errno == ERANGE)
assert(d == HUGE_VAL);
else
assert(errno == EDOM);
}
assert(fabs(lgamma(3.5) - log(tgamma(3.5))) < ERR);
}
/* Floating point manipulation functions. */
{
/*
# ldexp
ldexp(x, y) = x * (2^y)
*/
{
assert(fabs(ldexp(1.5, 2.0) - 6.0) < ERR);
}
/*
# nextafter
Return the next representable value in a direction.
If both arguments equal, return them.
# nexttowards
TODO diff from nextafter
*/
{
printf("nexttowards(0.0, 1.0) = %a\n", nexttoward(0.0, 1.0));
assert(nexttoward(0.0, 0.0) == 0.0);
printf("nextafter (0.0, 1.0) = %a\n", nextafter(0.0, 1.0));
}
}
/*
# Division by 0
Time to have some fun and do naughty things.
The outcome of a division by zero depends on wether it is an integer of floating operation.
# isfinite
# isinf
# isnan
# isnormal
TODO
# fpclassify
FP_INFINITE, FP_NAN, FP_NORMAL, FP_SUBNORMAL, FP_ZERO
*/
{
/*
# floating point exception
In x86, the following generates a floating point exception,
which is handled by a floating point exception handler function.
In Linux the default handler is implemented by the OS and sends a signal to our application,
which if we don't catch will kill us.
*/
if (0) {
/* gcc 4.7 is smart enough to warn on literal division by 0: */
{
/*int i = 1 / 0;*/
}
/* gcc 4.7 is not smart enough to warn here: */
{
volatile int i = 0;
printf("int 1/0 = %d\n", 1 / i);
/* On gcc 4.7 with `-O3` this may not generate an exception, */
/* as the compiler replaces 0 / X by 0. */
printf("int 0/0 = %d\n", 0 / i);
}
}
/*
# HUGE_VAL
Returned on overflow. TODO example.
Can equal `INFINITY`.
*/
{
/* double */
printf("HUGE_VAL = %f\n", HUGE_VAL);
/* float */
printf("HUGE_VALF = %f\n", HUGE_VALF);
/* long double */
printf("HUGE_VALL = %Lf\n", HUGE_VALL);
}
/*
# INFINITY
Result of operations such as:
1.0 / 0.0
Type: float.
There are two infinities: positive and negative.
It is possible that `INFINITY == HUGE_VALF`.
*/
{
/* [-]inf or [-]infinity implementation defined. */
printf("INFINITY = %f\n", INFINITY);
printf("-INFINITY = %f\n", -INFINITY);
volatile float f = 0;
assert(1 / f == INFINITY);
assert(isinf(INFINITY));
assert(!isnan(INFINITY));
assert(INFINITY + INFINITY == INFINITY);
assert(INFINITY + 1.0 == INFINITY);
assert(INFINITY - 1.0 == INFINITY);
assert(isnan(INFINITY - INFINITY));
assert(INFINITY * INFINITY == INFINITY);
assert(INFINITY * -INFINITY == -INFINITY);
assert(INFINITY * 2.0 == INFINITY);
assert(INFINITY * -1.0 == -INFINITY);
assert(isnan(INFINITY * 0.0));
assert(1.0 / INFINITY == 0.0);
assert(isnan(INFINITY / INFINITY));
/* Comparisons with INFINITY all work as expected. */
assert(INFINITY == INFINITY);
assert(INFINITY != - INFINITY);
assert(-INFINITY < - 1e100);
assert(1e100 < INFINITY);
}
/*
# NAN
Not a number.
Result of operations such as:
0.0 / 0.0
INFINITY - INFINITY
INFINITY * 0.o
INFINITY / INFINITY
And any operation involving NAN.
The sign of NAN has no meaning.
*/
{
/* [-]NAN or [-]NAN<more characters> implementation defined. */
printf("NAN = %f\n", NAN);
printf("-NAN = %f\n", -NAN);
/* TODO why do both fail? */
/*assert(0 / f == -NAN);*/
/*assert(0 / f == NAN);*/
volatile float f = 0;
assert(isnan(0 / f));
assert(isnan(NAN));
assert(!isinf(NAN));
assert(isnan(NAN));
assert(isnan(NAN + 1.0));
assert(isnan(NAN + INFINITY));
assert(isnan(NAN + NAN));
assert(isnan(NAN - 1.0));
assert(isnan(NAN * 2.0));
assert(isnan(NAN / 1.0));
assert(isnan(INFINITY - INFINITY));
assert(isnan(INFINITY * 0.0));
assert(isnan(INFINITY / INFINITY));
/*
NAN is not ordered. any compairison to it yields false!
This is logical since 0 is neither smaller, larger or equal to NAN.
*/
{
assert(!(0.0 < NAN));
assert(!(0.0 > NAN));
assert(!(0.0 == NAN));
}
}
#if __STDC_VERSION__ >= 199901L
/*
# isunordered
Macro.
isunordered(x, y)
Equals:
isnan(x) || isnan(y)
Likely exists because it is possible to optimize it in x86:
http://stackoverflow.com/questions/26053934/is-it-feasible-to-add-this-optimization-to-gcc?rq=1
*/
{
assert(!isunordered(1.0, 1.0));
assert(isunordered(NAN, 1.0));
assert(isunordered(1.0, NAN));
assert(isunordered(NAN, NAN));
}
#endif
}
/*
# FLT_EVAL_METHOD
# float_t
# double_t
*/
{
printf("FLT_EVAL_METHOD = %d\n", FLT_EVAL_METHOD);
}
return EXIT_SUCCESS;
}
/* Coordinate descent, multi-task
*
* This function will only work for quadratic functions like linear loss and
* squared hinge loss, since it assumes that the Newton step for each variable
* is exact. It's easy to modify it to loop over the Newton steps until some
* convergence is achieved, e.g., for logistic loss.
* */
int cd_gmatrix(gmatrix *g,
step step_func,
const int maxepochs,
const int maxiters,
const double lambda1,
const double lambda2,
const double gamma,
const double trunc,
int *numactiveK)
{
const int p1 = g->p + 1, K = g->K;
int j, k, allconverged = 0, numactive = 0,
epoch = 1,
good = FALSE;
double beta_new, delta, s;
const double l2recip = 1 / (1 + lambda2);
sample sm;
double *beta_old = NULL;
int *active_old = NULL;
long pkj, p1K1 = p1 * K - 1, kK1;
int v1, v2, e, l;
int nE = K * (K - 1) / 2;
double d1, d2, df1, df2, sv;
double beta_pkj;
double lossold = g->loss;
int mult = 2, idx;
int mx, i, m;
double tmp;
if(!sample_init(&sm))
return FAILURE;
CALLOCTEST(beta_old, (long)p1 * K, sizeof(double));
CALLOCTEST(active_old, (long)p1 * K, sizeof(int));
//for(j = p1K1 ; j >= 0 ; --j)
// active_old[j] = g->active[j] = !g->ignore[j];
while(epoch <= maxepochs)
{
numactive = 0;
for(k = 0 ; k < K ; k++)
{
numactiveK[k] = 0;
kK1 = k * (K - 1);
for(j = 0 ; j < p1; j++)
{
pkj = (long)p1 * k + j;
beta_pkj = g->beta[pkj];
beta_new = beta_old[pkj] = beta_pkj;
if(g->active[pkj])
{
if(!g->nextcol(g, &sm, j, NA_ACTION_PROPORTIONAL))
return FAILURE;
step_func(&sm, g, k, &d1, &d2);
/* don't penalise intercept */
if(j > 0)
{
/* fusion penalty */
df1 = 0;
df2 = 0;
if(g->dofusion)
{
/* for each task k, compute derivative over
* the K-1 other tasks, as each task has K-1 pairs
*/
for(l = K - 2 ; l >= 0 ; --l)
{
e = g->edges[l + kK1];
v1 = g->pairs[e];
v2 = g->pairs[e + nE];
sv = g->beta[j + v1 * p1] * g->C[e + v1 * nE]
+ g->beta[j + v2 * p1] * g->C[e + v2 * nE];
df1 += sv * g->C[e + k * nE];
}
/* derivatives of fusion loss */
df1 *= gamma;
df2 = gamma * g->diagCC[k];
}
s = beta_pkj - (d1 + df1) / (d2 + df2);
beta_new = soft_threshold(s, lambda1) * l2recip;
}
else
s = beta_new = beta_pkj - d1 / d2;
/* numerically close enough to zero */
if(fabs(beta_new) < ZERO_THRESH)
beta_new = 0;
delta = beta_new - beta_pkj;
if(delta != 0)
updateloss(g, beta_pkj, delta, sm.x, j, k, lambda1, gamma, nE);
/* intercept always deemed active */
g->active[pkj] = (j == 0) || (g->beta[pkj] != 0);
}
numactiveK[k] += g->active[pkj];
numactive += g->active[pkj];
}
}
g->loss = 0;
for(i = 0 ; i < g->ncurr ; i++)
{
for(k = 0 ; k < g->K ; k++)
{
m = i + k * g->ncurr;
tmp = (g->lp[m] - g->y[m]) * (g->lp[m] - g->y[m]);
g->loss += tmp;
}
}
g->loss /= (2.0 * g->ncurr);
g->l1loss = 0;
for(j = 1 ; j < p1 ; j++)
for(k = 0 ; k < K ; k++)
g->l1loss += fabs(g->beta[j + k * p1]);
g->loss += lambda1 * g->l1loss;
if(g->dofusion)
{
g->floss = 0;
for(j = p1 - 1 ; j >= 1 ; --j)
{
for(e = nE - 1 ; e >= 0 ; --e)
{
v1 = g->pairs[e];
v2 = g->pairs[e + nE];
sv = g->beta[j + v1 * p1] * g->C[e + v1 * nE]
+ g->beta[j + v2 * p1] * g->C[e + v2 * nE];
g->floss += sv * sv;
}
}
g->loss += gamma * 0.5 * g->floss;
}
if(fabs(g->loss - lossold) / fabs(lossold) < g->tol)
allconverged++;
else
{
allconverged = 0;
//printf("%d loss: %.6f lossold: %.6f\n", epoch, g->loss, lossold);
}
if(allconverged == 1)
{
/* reset active-set to contain all (non monomorphic) coordinates, in
* order to check whether non-active coordinates become active again
* or vice-versa */
for(j = p1K1 ; j >= 0 ; --j)
{
active_old[j] = g->active[j];
g->active[j] = !g->ignore[j];
}
if(g->verbose)
{
timestamp();
printf(" resetting activeset at epoch %d, loss: %.6f floss: %.6f\n",
epoch, g->loss, g->floss);
}
mult = 2;
}
else if(allconverged == 2)
{
for(j = p1K1 ; j >= 0 ; --j)
if(g->active[j] != active_old[j])
break;
if(j < 0)
{
if(g->verbose)
{
timestamp();
printf(" terminating at epoch %d with %d active vars\n",
epoch, numactive);
}
good = TRUE;
break;
}
if(g->verbose)
{
timestamp();
printf(" active set changed, %d active vars, mx:", numactive);
}
/* keep iterating over existing active set, keep track
* of the current active set */
for(j = p1K1 ; j >= 0 ; --j)
active_old[j] = g->active[j];
/* double the size of the active set */
for(k = 0 ; k < K ; k++)
{
mx = fminl(mult * numactiveK[k], p1);
printf("%d ", mx);
for(j = mx - 1 ; j >= 0 ; --j)
{
idx = g->grad_array[j + k * p1].index + k * p1;
g->active[idx] = !g->ignore[idx];
}
}
printf("\n");
allconverged = 0;
mult *= 2;
}
epoch++;
lossold = g->loss;
}
if(g->verbose)
printf("\n");
FREENULL(beta_old);
FREENULL(active_old);
return good ? numactive : CDFAILURE;
}