DLLEXPORT MKL_INT d_thin_qr_solve(MKL_INT m, MKL_INT n, MKL_INT bn, double a[], double b[], double x[], double work[], MKL_INT len)
{
MKL_INT info = 0;
double* clone_a = new double[m*n];
std::memcpy(clone_a, a, m*n*sizeof(double));
double* clone_b = new double[m*bn];
std::memcpy(clone_b, b, m*bn*sizeof(double));
char N = 'N';
dgels_(&N, &m, &n, &bn, clone_a, &m, clone_b, &m, work, &len, &info);
for (MKL_INT i = 0; i < n; ++i)
{
for (MKL_INT j = 0; j < bn; ++j)
{
x[j * n + i] = clone_b[j * m + i];
}
}
delete[] clone_a;
delete[] clone_b;
return info;
}
int least_squares(int m, int n, double **matrix)
{
if(m < 1 || n < 1 || n > m) return LS_DIMENSION_ERROR;
int i, j;
int info, lwork = m*m;
double *work; if(!allocate_double_vector(&work, lwork)) { return LS_MEMORY_ERROR; }
char transa = 'N';
double **a_matrix; if(!allocate_double_matrix(&a_matrix, n, m)) { return LS_MEMORY_ERROR; }
for(i = 0; i < m; i ++) for(j = 0; j < n; j ++) a_matrix[j][i] = matrix[j][i];
double **b_matrix; if(!allocate_double_matrix(&b_matrix, m, m)) { return LS_MEMORY_ERROR; }
for(i = 0; i < m; i ++) for(j = 0; j < m; j ++) b_matrix[i][j] = (i == j);
dgels_(&transa, &m, &n, &m, a_matrix[0], &m, b_matrix[0], &m, work, &lwork, &info);
for(i = 0; i < n; i ++) for(j = 0; j < m; j ++) matrix[i][j] = b_matrix[j][i];
free_matrix((void**)a_matrix);
free_matrix((void**)b_matrix);
free_vector(work);
return LS_SUCCESS;
}
/*! solve overdetermined or underdetermined A*X=Y using dgels
with the sum of residual squares output\n
The residual is set as the columnwise sum of residual squares
for overdetermined problems
while it is always zero for underdetermined problems.
*/
inline long dgematrix::dgels(dgematrix& mat, drovector& residual)
{
#ifdef CPPL_VERBOSE
std::cerr << "# [MARK] dgematrix::dgels(dgematrix&, drovector&)"
<< std::endl;
#endif//CPPL_VERBOSE
#ifdef CPPL_DEBUG
if(M!=mat.M){
std::cerr << "[ERROR] dgematrix::dgels(dgematrix&, drovector&) "
<< std::endl
<< "These two matrices cannot be solved." << std::endl
<< "Your input was (" << M << "x" << N << ") and ("
<< mat.M << "x" << mat.N << ")." << std::endl;
exit(1);
}
#endif//CPPL_DEBUG
residual.resize(mat.N); residual.zero();
if(M<N){ //underdetermined
dgematrix tmp(N,mat.N);
for(long i=0; i<mat.M; i++){ for(long j=0; j<mat.N; j++){
tmp(i,j) =mat(i,j);
}}
mat.clear();
swap(mat,tmp);
}
char TRANS('N');
long NRHS(mat.N), LDA(M), LDB(mat.M),
LWORK(min(M,N)+max(min(M,N),NRHS)), INFO(1);
double *WORK(new double[LWORK]);
dgels_(TRANS, M, N, NRHS, Array, LDA, mat.Array, LDB, WORK, LWORK, INFO);
delete [] WORK;
if(M>N){ //overdetermined
for(long i=0; i<residual.L; i++){ for(long j=0; j<M-N; j++){
residual(i) += std::pow(mat(N+j,i), 2.0);
}}
dgematrix tmp(N,mat.N);
for(long i=0; i<tmp.M; i++){ for(long j=0; j<tmp.N; j++){
tmp(i,j) =mat(i,j);
}}
mat.clear();
swap(mat,tmp);
}
if(INFO!=0){
std::cerr << "[WARNING] dgematrix::dgels(dgematrix&, drovector&) "
<< "Serious trouble happend. INFO = " << INFO << "."
<< std::endl;
}
return INFO;
}
void THLapack_(gels)(char trans, int m, int n, int nrhs, real *a, int lda, real *b, int ldb, real *work, int lwork, int *info)
{
#ifdef USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
dgels_(&trans, &m, &n, &nrhs, a, &lda, b, &ldb, work, &lwork, info);
#else
sgels_(&trans, &m, &n, &nrhs, a, &lda, b, &ldb, work, &lwork, info);
#endif
#else
THError("gels : Lapack library not found in compile time\n");
#endif
}
void THLapack_(gels)(char trans, int m, int n, int nrhs, real *a, int lda, real *b, int ldb, real *work, int lwork, int *info)
{
#ifdef USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
extern void dgels_(char *trans, int *m, int *n, int *nrhs, double *a, int *lda, double *b, int *ldb, double *work, int *lwork, int *info);
dgels_(&trans, &m, &n, &nrhs, a, &lda, b, &ldb, work, &lwork, info);
#else
extern void sgels_(char *trans, int *m, int *n, int *nrhs, float *a, int *lda, float *b, int *ldb, float *work, int *lwork, int *info);
sgels_(&trans, &m, &n, &nrhs, a, &lda, b, &ldb, work, &lwork, info);
#endif
#else
THError("gels : Lapack library not found in compile time\n");
#endif
}
/*! solve overdetermined or underdetermined A*x=y using dgels
with the sum of residual squares output\n
The residual is set as the sum of residual squares
for overdetermined problems
while it is always zero for underdetermined problems.
*/
inline long dgematrix::dgels(dcovector& vec, double& residual)
{
#ifdef CPPL_VERBOSE
std::cerr << "# [MARK] dgematrix::dgels(dcovector&, double&)"
<< std::endl;
#endif//CPPL_VERBOSE
#ifdef CPPL_DEBUG
if(M!=vec.L){
std::cerr << "[ERROR] dgematrix::dgels(dcovector&, double&) " << std::endl
<< "These matrix and vector cannot be solved." << std::endl
<< "Your input was (" << M << "x" << N << ") and ("
<< vec.L << ")." << std::endl;
exit(1);
}
#endif//CPPL_DEBUG
residual=0.0;
if(M<N){ //underdetermined
dcovector tmp(N);
for(long i=0; i<vec.L; i++){ tmp(i)=vec(i); }
vec.clear();
swap(vec,tmp);
}
char TRANS('N');
long NRHS(1), LDA(M), LDB(vec.L),
LWORK(min(M,N)+max(min(M,N),NRHS)), INFO(1);
double *WORK(new double[LWORK]);
dgels_(TRANS, M, N, NRHS, Array, LDA, vec.Array, LDB, WORK, LWORK, INFO);
delete [] WORK;
if(M>N){ //overdetermined
for(long i=0; i<M-N; i++){ residual+=std::pow(vec(N+i),2.0); }
dcovector tmp(N);
for(long i=0; i<tmp.L; i++){ tmp(i)=vec(i); }
vec.clear();
swap(vec,tmp);
}
if(INFO!=0){
std::cerr << "[WARNING] dgematrix::dgels(dcovector&, double&) "
<< "Serious trouble happend. INFO = " << INFO << "."
<< std::endl;
}
return INFO;
}
int CLapack::gels(CFortranMatrix& a,CVector& rhs)
{
char trans = 'N';
int m = a.GetNumberOfRows();
int n = a.GetNumberOfColumns();
int nrhs = 1;
int lda = m;
int ldb = std::max(m,n);
int info = 0;
// query work size
int lwork = -1;
double twork[1];
dgels_(&trans,&m,&n,&nrhs,a.GetRawDataField(),&lda,rhs.GetRawDataField(),&ldb,
twork,&lwork,&info);
if( info != 0 ){
CSmallString error;
error << "unable to determine lwork, info = " << info;
INVALID_ARGUMENT(error);
}
lwork = static_cast<int>(twork[0]) + 1;
// printf("lwork = %d\n",lwork);
CSimpleVector<double> work;
work.CreateVector(lwork);
// run
dgels_(&trans,&m,&n,&nrhs,a.GetRawDataField(),&lda,rhs.GetRawDataField(),&ldb,
work.GetRawDataField(),&lwork,&info);
return(info);
}
bool GeneralizedProcrustes::computeRotationAlignment(Shape & cont, double * partialAverage)
{
long int i, numberOfNodes, dimension, lwork, info;
double alpha, beta, determinant;
char job, trans;
bool returnval;
// Compute the best rigid alignment based on minNumNodes first vertices:
numberOfNodes = cont.numberVertices;
dimension = 3;
job = 'A';
trans = 'N';
alpha = 1.0;
beta = 0.0;
lwork = 2*minNumNodes;
double * work = new double[lwork];
double * A = new double[minNumNodes * dimension];
double * b = new double[minNumNodes * dimension];
double * S = new double[dimension];
double * U = new double[dimension*dimension];
double * VT = new double[dimension*dimension];
double * R = new double[dimension*dimension];
returnval = true;
//printf("cont.vertexCoordinates[i][0]:%f\n",cont.vertexCoordinates[0][0]);
//populate the arrays A and b:
for(i = 0; i < minNumNodes; i++)
{
A[i] = cont.vertexCoordinates[i][0];
A[minNumNodes + i] = cont.vertexCoordinates[i][1];
A[2*minNumNodes + i] = cont.vertexCoordinates[i][2];
b[i] = partialAverage[i];
b[minNumNodes + i] = partialAverage[minNumNodes + i];
b[2*minNumNodes + i] = partialAverage[2*minNumNodes + i];
}
//compute an estimate of R:
dgels_(&trans, &minNumNodes, &dimension, &dimension, A, &minNumNodes, b, &minNumNodes, work, &lwork, &info);
if(info != 0)
{
printf("Problem with estimating R %s\n", info);
goto align_EXIT;
}
//make sure that R is a valid matrix (orthonormal): b contains R
delete [] work;
lwork = 5*dimension;
work = new double[lwork];
//only copy 3 by 3 submatrix to R:
for(i = 0; i < dimension; i++)
{
R[i] = b[i];
R[dimension + i] = b[minNumNodes + i];
R[2*dimension + i] = b[2*minNumNodes + i];
}
dgesvd_(&job, &job, &dimension, &dimension, R, &dimension, S, U, &dimension, VT, &dimension, work,
&lwork, &info);
if(info != 0)
{
printf("Problem with estimating R in SVD %s\n",info);
goto align_EXIT;
}
//set S to I: multiply U times VT:
dgemm_(&trans, &trans, &dimension, &dimension, &dimension, &alpha, U, &dimension, VT, &dimension, &beta,
R, &dimension);
//disallow reflections:
determinant = R[0]*R[4]*R[8]+R[1]*R[5]*R[6]+R[2]*R[3]*R[7]-R[2]*R[4]*R[6]-R[0]*R[5]*R[7]-R[1]*R[3]*R[8];
if(determinant < 0)
{
printf("Determinant is %d\n", determinant);
returnval = false;
goto align_EXIT;
}
//transform ALL the coordinates:
lwork = 2*numberOfNodes;
delete [] work;
work = new double[lwork];
delete [] A;
A = new double[numberOfNodes * dimension];
delete [] b;
b = new double[numberOfNodes * dimension];
//populate the array A again as it got destroyed:
for(i = 0; i < numberOfNodes; i++)
{
A[i] = cont.vertexCoordinates[i][0];
A[numberOfNodes + i] = cont.vertexCoordinates[i][1];
A[2*numberOfNodes + i] = cont.vertexCoordinates[i][2];
}
//do the rigid transformation and set it to shape:
dgemm_(&trans, &trans, &numberOfNodes, &dimension, &dimension, &alpha, A, &numberOfNodes, R, &dimension, &beta,
b, &numberOfNodes);
for(i = 0; i < numberOfNodes; i++)
{
// printf("cont.vertexCoordinates[i][0]:%f b[i] %f\n", cont.vertexCoordinates[i][0] ,b[i]);
cont.vertexCoordinates[i][0] = b[i];
cont.vertexCoordinates[i][1] = b[numberOfNodes + i];
cont.vertexCoordinates[i][2] = b[2*numberOfNodes + i];
}
align_EXIT:
delete [] work;
delete [] A;
delete [] b;
delete [] S;
delete [] U;
delete [] VT;
delete [] R;
return returnval;
}
int constrained_least_squares(int m, int n, double **matrix, int c, int *constrained)
{
//check problem dimensions
if(m < 1 || n < 1 || n > m || c > n) return LS_DIMENSION_ERROR;
//counters
int i, j;
//extra problem dimensions
int f = m - c, u = n - c;
//lapack and blas inputs
char transa, transb;
double alpha, beta;
//lapack output
int info;
//lapack workspace
int lwork = m*m;
double *work; if(!allocate_double_vector(&work, lwork)) { return LS_MEMORY_ERROR; }
//lapack LU pivot indices
int *ipiv; if(!allocate_integer_vector(&ipiv,c)) { return LS_MEMORY_ERROR; }
//lapack coefficients of QR elementary reflectors
double *tau; if(!allocate_double_vector(&tau,c)) { return LS_MEMORY_ERROR; }
//matrices used
double **t_matrix; if(!allocate_double_matrix(&t_matrix, m, m)) { return LS_MEMORY_ERROR; }
double **c_matrix; if(!allocate_double_matrix(&c_matrix, n, n)) { return LS_MEMORY_ERROR; }
double **r_matrix; if(!allocate_double_matrix(&r_matrix, c, c)) { return LS_MEMORY_ERROR; }
double **a_matrix; if(!allocate_double_matrix(&a_matrix, n, f)) { return LS_MEMORY_ERROR; }
double **d_matrix; if(!allocate_double_matrix(&d_matrix, f, f)) { return LS_MEMORY_ERROR; }
//indices of unconstrained equations
int *temp, *unconstrained;
if(!allocate_integer_vector(&temp,m)) { return LS_MEMORY_ERROR; }
if(!allocate_integer_vector(&unconstrained,f)) { return LS_MEMORY_ERROR; }
//create vector of unconstrained indices
for(i = 0; i < m; i ++) temp[i] = 0;
for(i = 0; i < c; i ++) temp[constrained[i]] = 1;
j = 0;
for(i = 0; i < m; i ++) if(!temp[i]) unconstrained[j++] = i;
//copy unconstrained equations from input matrix -> t_matrix
for(i = 0; i < f; i ++) for(j = 0; j < n; j ++) t_matrix[i][j] = matrix[j][unconstrained[i]];
//copy constrained equations from input matrix -> c_matrix
for(i = 0; i < c; i ++) for(j = 0; j < n; j ++) c_matrix[i][j] = matrix[j][constrained[i]];
//QR decomposition of the transposed constrained equations -> c_matrix
dgeqrf_(&n, &c, c_matrix[0], &n, tau, work, &lwork, &info);
//copy R out of the above QR decomposition -> r_matrix
for(i = 0; i < c; i ++) for(j = 0; j < c; j ++) r_matrix[i][j] = ((j >= i) ? c_matrix[j][i] : 0);
//form the square matrix Q from the above QR decomposition -> c_matrix'
dorgqr_(&n, &n, &c, c_matrix[0], &n, tau, work, &lwork, &info);
//multiply unconstrained eqations by Q -> a_matrix'
transa = 'T'; transb = 'N'; alpha = 1.0; beta = 0.0;
dgemm_(&transa, &transb, &f, &n, &n, &alpha, t_matrix[0], &m, c_matrix[0], &n, &beta, a_matrix[0], &f);
//invert R' of the above QR decomposition -> r_matrix
dgetrf_(&c, &c, r_matrix[0], &c, ipiv, &info);
dgetri_(&c, r_matrix[0], &c, ipiv, work, &lwork, &info);
//LS inversion of the non-square parts from unconstrained * Q -> d_matrix'
for(i = 0; i < f; i ++) for(j = 0; j < u; j ++) t_matrix[j][i] = a_matrix[j+c][i];
for(i = 0; i < f; i ++) for(j = 0; j < f; j ++) d_matrix[i][j] = (i == j);
transa = 'N';
dgels_(&transa, &f, &u, &f, t_matrix[0], &m, d_matrix[0], &f, work, &lwork, &info);
//multiply matrices together to form the CLS solution -> t_matrix'
transa = transb = 'N'; alpha = 1.0; beta = 0.0;
dgemm_(&transa, &transb, &n, &f, &u, &alpha, c_matrix[c], &n, d_matrix[0], &f, &beta, t_matrix[0], &m);
alpha = -1.0; beta = 1.0;
dgemm_(&transa, &transb, &n, &c, &f, &alpha, t_matrix[0], &m, a_matrix[0], &f, &beta, c_matrix[0], &n);
alpha = 1.0; beta = 0.0;
dgemm_(&transa, &transb, &n, &c, &c, &alpha, c_matrix[0], &n, r_matrix[0], &c, &beta, t_matrix[f], &m);
//copy the result out of the temporary matrix -> matrix
for(i = 0; i < n; i ++) for(j = 0; j < f; j ++) matrix[i][unconstrained[j]] = t_matrix[j][i];
for(i = 0; i < n; i ++) for(j = 0; j < c; j ++) matrix[i][constrained[j]] = t_matrix[j+f][i];
//clean up and return successful
free_vector(work);
free_vector(ipiv);
free_vector(tau);
free_vector(temp);
free_vector(unconstrained);
free_matrix((void **)t_matrix);
free_matrix((void **)c_matrix);
free_matrix((void **)r_matrix);
free_matrix((void **)a_matrix);
free_matrix((void **)d_matrix);
return LS_SUCCESS;
}
/**
* \brief compute the calibration data from the raw points
*
* The guider port activations move a star over the ccd area. The velocity
* of this movement is measure in pixels/second. The vector of movement
* induced by the activation of the right ascension guider port controls
* has components vx_ra and vy_ra, they are unknowns 0 and 3. The velocity
* induced by declination port activation has components vx_dec and vy_dec,
* they are unknowns 1 and 4. The drift velocity describes the movement of
* the star without any controls applied, they are drift_x and drift_y,
* unknowns 2 and 5. The remaining two unknowns 6 and 7 are origin_x and
* origin_y, they are the best estimate of the origin at the beginning of the
* calibration process (time origin).
*/
GuiderCalibration GuiderCalibrator::calibrate() {
// build the linear system of equations
int m = 2 * _calibration.size(); // number of equations
int n = 8; // number of unknowns
double A[n * m];
double b[m];
// fill in equations
std::vector<CalibrationPoint>::const_iterator ci;
int i = 0;
for (ci = _calibration.begin(); ci != _calibration.end(); ci++){
A[i ] = ci->offset.x(); // vx_ra
A[i + m] = ci->offset.y(); // vx_dec
A[i + 2 * m] = ci->t; // drift_x
A[i + 3 * m] = 0; // vy_ra
A[i + 4 * m] = 0; // vy_dec
A[i + 5 * m] = 0; // drift_y
A[i + 6 * m] = 1; // origin_x
A[i + 7 * m] = 0; // origin_y
b[i] = ci->star.x();
i++;
A[i ] = 0;
A[i + m] = 0;
A[i + 2 * m] = 0;
A[i + 3 * m] = ci->offset.x();
A[i + 4 * m] = ci->offset.y();
A[i + 5 * m] = ci->t;
A[i + 6 * m] = 0;
A[i + 7 * m] = 1;
b[i] = ci->star.y();
i++;
}
// prepare to solve the system using LAPACK (dgels_)
char trans = 'N';
int nrhs = 1;
int lda = m;
int ldb = m;
int lwork = -1;
int info = 0;
// determine work area size
double x;
dgels_(&trans, &m ,&n, &nrhs, A, &lda, b, &ldb, &x, &lwork, &info);
if (info != 0) {
std::string msg = stringprintf("dgels cannot determine "
"work area size: %d", info);
debug(LOG_ERR, DEBUG_LOG, 0, "%s", msg.c_str());
throw std::runtime_error(msg);
}
lwork = x;
debug(LOG_DEBUG, DEBUG_LOG, 0, "need work area of size %d", lwork);
// allocate work array
double work[lwork];
dgels_(&trans, &m ,&n, &nrhs, A, &lda, b, &ldb, work, &lwork, &info);
if (info != 0) {
std::string msg = stringprintf("dgels cannot solve "
"equations: %d", info);
debug(LOG_ERR, DEBUG_LOG, 0, "%s", msg.c_str());
throw std::runtime_error(msg);
}
// store the results in the calibration data array
for (unsigned int i = 0; i < 6; i++) {
_calibration.a[i] = b[i];
}
// The last two variables are not needed for the calibration, we
// throw them away but it might be interesting to at least note them
// in the debug log.
debug(LOG_DEBUG, DEBUG_LOG, 0, "calibration origin: %.3f, %.3f",
b[6], b[7]);
// return the calibration data
return _calibration;
}
int
KrylovAccelerator2::accelerate(Vector &vStar, LinearSOE &theSOE,
IncrementalIntegrator &theIntegrator)
{
const Vector &R = theSOE.getB();
int k = dimension;
// Store residual for differencing at next iteration
*(Av[k]) = R;
// If subspace is not empty
if (dimension > 0) {
// Compute Av_k = f(y_{k-1}) - f(y_k) = r_{k-1} - r_k
Av[k-1]->addVector(1.0, R, -1.0);
int i,j;
// Put subspace vectors into AvData
Matrix A(AvData, numEqns, k);
for (i = 0; i < k; i++) {
Vector &Ai = *(Av[i]);
for (j = 0; j < numEqns; j++)
A(j,i) = Ai(j);
}
for (i = 0; i < k; i++) {
for (int j = i+1; j < k; j++) {
double sum = 0.0;
double sumi = 0.0;
double sumj = 0.0;
for (int ii = 0; ii < numEqns; ii++) {
sum += A(ii,i)*A(ii,j);
sumi += A(ii,i)*A(ii,i);
sumj += A(ii,j)*A(ii,j);
}
sumi = sqrt(sumi);
sumj = sqrt(sumj);
sum = sum/(sumi*sumj);
//if (fabs(sum) > 0.99)
//opserr << sum << ' ' << i << ' ' << j << " ";
}
}
// Put residual vector into rData (need to save r for later!)
Vector B(rData, numEqns);
B = R;
// No transpose
char *trans = "N";
// The number of right hand side vectors
int nrhs = 1;
// Leading dimension of the right hand side vector
int ldb = (numEqns > k) ? numEqns : k;
// Subroutine error flag
int info = 0;
// Call the LAPACK least squares subroutine
#ifdef _WIN32
unsigned int sizeC = 1;
DGELS(trans, &sizeC, &numEqns, &k, &nrhs, AvData, &numEqns,
rData, &ldb, work, &lwork, &info);
#else
//SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
// $ INFO )
dgels_(trans, &numEqns, &k, &nrhs, AvData, &numEqns,
rData, &ldb, work, &lwork, &info);
#endif
// Check for error returned by subroutine
if (info < 0) {
opserr << "WARNING KrylovAccelerator2::accelerate() - \n";
opserr << "error code " << info << " returned by LAPACK dgels\n";
return info;
}
Vector Q(numEqns);
Q = R;
// Compute the correction vector
double cj;
for (j = 0; j < k; j++) {
// Solution to least squares is written to rData
cj = rData[j];
// Compute w_{k+1} = c_1 v_1 + ... + c_k v_k
vStar.addVector(1.0, *(v[j]), cj);
// Compute least squares residual
// q_{k+1} = r_k - (c_1 Av_1 + ... + c_k Av_k)
Q.addVector(1.0, *(Av[j]), -cj);
}
theSOE.setB(Q);
//opserr << "Q: " << Q << endln;
}
theSOE.solve();
vStar.addVector(1.0, theSOE.getX(), 1.0);
// Put accelerated vector into storage for next iteration
*(v[k]) = vStar;
dimension++;
return 0;
}
/**
* \brief
*/
cv::Mat findTransform(cv::Mat& before, cv::Mat& after, int l = 64) {
// prepare the result array
cv::Mat transform(2, 3, CV_64FC1);
transform.at<double>(0, 0) = 1;
transform.at<double>(0, 1) = 0;
transform.at<double>(0, 2) = 0;
transform.at<double>(1, 0) = 0;
transform.at<double>(1, 1) = 1;
transform.at<double>(1, 2) = 0;
// compute the center of the image
int width = before.cols;
int height = after.rows;
cv::Point center = cv::Point(width/2, height/2);
// compute grid parameters
int l2 = l / 2;
int x0 = center.x - l * trunc(center.x / l) + l2;
int y0 = center.y - l * trunc(center.y / l) + l2;
double tx = 0, ty = 0;
// iterate over the grid and compute the local translation in each
// grid point. This will give the grid we need for LAPACK to compute
// the optimal transformation
typedef std::pair<cv::Point2d, cv::Point2d> pointpair;
std::vector<pointpair> translates;
for (int x = x0; x + l2 < width; x += l) {
for (int y = y0; y + l2 < height; y += l) {
cv::Point2d tilecenter(x, y);
cv::Point2d translation = getshift(cv::Rect(x - l2, y - l2, l, l), before, after);
translates.push_back(std::make_pair(tilecenter, translation));
tx += translation.x;
ty += translation.y;
}
}
// now compute the optimal affine transformation
std::cout << "size: " << translates.size() << std::endl;
double a[12 * translates.size()];
double b[2 * translates.size()];
std::vector<pointpair>::const_iterator pair;
int m = 2 * translates.size();
int i = 0;
for (pair = translates.begin(); pair != translates.end(); pair++, i++) {
// add coefficients to A array
a[2 * i ] = pair->first.x;
a[2 * i + m] = pair->first.y;
a[2 * i + 2 * m] = 1;
a[2 * i + 3 * m] = 0;
a[2 * i + 4 * m] = 0;
a[2 * i + 5 * m] = 0;
a[2 * i + 1 ] = 0;
a[2 * i + 1 + m] = 0;
a[2 * i + 1 + 2 * m] = 0;
a[2 * i + 1 + 3 * m] = pair->first.x;
a[2 * i + 1 + 4 * m] = pair->first.y;
a[2 * i + 1 + 5 * m] = 1;
// add positions to B array
b[2 * i ] = pair->first.x + pair->second.x;
b[2 * i + 1] = pair->first.y + pair->second.y;
}
std::cout << "arrays prepared" << std::endl;
// now use LAPACK to solve the system of equations
char trans = 'N';
int n = 6;
int nrhs = 1;
int lda = m;
int ldb = m;
int lwork = -1;
int info = 0;
// first perform a call to find out how much data is needed
std::cout << "calling dgels" << std::endl;
double x;
dgels_(&trans, &m, &n, &nrhs, a, &lda, b, &ldb, &x, &lwork, &info);
if (info != 0) {
std::cerr << "dgels lwork determination failed: " << info << std::endl;
exit(EXIT_FAILURE);
}
lwork = x;
std::cout << "lwork = " << lwork << std::endl;
// now allocate the work array and perform the real computation
double work[lwork];
dgels_(&trans, &m, &n, &nrhs, a, &lda, b, &ldb, work, &lwork, &info);
if (info != 0) {
std::cerr << "dgels solution failed: " << info << std::endl;
}
transform.at<double>(0, 0) = b[0];
transform.at<double>(0, 1) = b[1];
transform.at<double>(0, 2) = b[2];
transform.at<double>(1, 0) = b[3];
transform.at<double>(1, 1) = b[4];
transform.at<double>(1, 2) = b[5];
// just for comparison, also compute the
return transform;
}
/**
* \brief Find the optimal transform from one set of points to the other
*/
Transform::Transform(const std::vector<Residual>& residuals) {
// make sure we have enough points
if (residuals.size() < 3) {
debug(LOG_DEBUG, DEBUG_LOG, 0, "not enough data for full "
"transform, extracting translation only");
translation(residuals);
return;
}
debug(LOG_DEBUG, DEBUG_LOG, 0, "determine best transformation between two sets of %d points", residuals.size());
// allocate space for the linear system
int m = 2 * residuals.size();
double A[6 * m];
double b[m];
debug(LOG_DEBUG, DEBUG_LOG, 0, "A size: %d, b size: %d", 6 * m, m);
// set up linear system of equations
std::vector<Residual>::const_iterator residual;
int i = 0;
for (residual = residuals.begin(); residual != residuals.end();
residual++) {
// add coefficients to A array
A[i ] = residual->from().x();
A[i + m] = residual->from().y();
A[i + 2 * m] = 1;
A[i + 3 * m] = 0;
A[i + 4 * m] = 0;
A[i + 5 * m] = 0;
b[i] = residual->offset().x();
i++;
A[i ] = 0;
A[i + m] = 0;
A[i + 2 * m] = 0;
A[i + 3 * m] = residual->from().x();
A[i + 4 * m] = residual->from().y();
A[i + 5 * m] = 1;
b[i] = residual->offset().y();
i++;
}
debug(LOG_DEBUG, DEBUG_LOG, 0, "number of equations: %d", i);
// solve the linear system
char trans = 'N';
int n = 6;
int nrhs = 1;
int lda = m;
int ldb = m;
int lwork = -1;
int info = 0;
// first call to dgels is set up to determine the needed size of the
// work array.
double x;
dgels_(&trans, &m, &n, &nrhs, A, &lda, b, &ldb, &x, &lwork, &info);
if (info != 0) {
std::string msg = stringprintf("dgels cannot determine "
"work area size: %d", info);
debug(LOG_ERR, DEBUG_LOG, 0, "%s", msg.c_str());
throw std::runtime_error(msg);
}
lwork = x;
debug(LOG_DEBUG, DEBUG_LOG, 0, "need work area of size %d", lwork);
// with the correct work array in place, the next call solves the
// equations
double work[lwork];
dgels_(&trans, &m, &n, &nrhs, A, &lda, b, &ldb, work, &lwork, &info);
if (info != 0) {
std::string msg = stringprintf("dgels cannot solve "
"equations: %d", info);
debug(LOG_ERR, DEBUG_LOG, 0, "%s", msg.c_str());
throw std::runtime_error(msg);
}
// copy result vector
for (int i = 0; i < 6; i++) {
a[i] = b[i];
}
debug(LOG_DEBUG, DEBUG_LOG, 0, "transformation found: %s",
this->toString().c_str());
}
// Perform a moving linear least squares interpolation to arrays
// Input arguments:
// order: order of polynomial used (1 or 2)
// cutoff: the cutoff of weight (in grid points)
// coords: scaled coords [0,1] for interpolation
// N_c: number of grid points
// beg_c: first grid point
// data: the array used
// target: the results are stored in this array
PyObject* mlsqr(PyObject *self, PyObject *args)
{
// The order of interpolation
unsigned char order = -1;
// The cutoff for moving least squares
double cutoff = -1;
// The coordinates for interpolation: array of size (3, N)
PyArrayObject* coords = 0;
// Number of grid points
PyArrayObject* N_c = 0;
// Beginning of grid
PyArrayObject* beg_c = 0;
// The 3d-data to be interpolated: array of size (X, Y, Z)
PyArrayObject* data;
// The interpolation target: array of size (N,)
PyArrayObject* target = 0;
if (!PyArg_ParseTuple(args, "BdOOOOO", &order, &cutoff, &coords, &N_c, &beg_c, &data, &target))
{
return NULL;
}
int coeffs = -1;
if (order == 1)
{
coeffs = 4;
}
if (order == 2)
{
coeffs = 10;
// 1 x y z xy yz zx xx yy zz
}
if (order == 3)
{
// 1 x y z xy yz zx xx yy zz
// xxy xxz yyx yyz zzx zzy
// xxx yyy zzz zyz
coeffs = 20;
}
int points = coords->dimensions[0];
double* coord_nc = DOUBLEP(coords);
double* grid_points = DOUBLEP(N_c);
double* grid_start = DOUBLEP(beg_c);
double* target_n = DOUBLEP(target);
double* data_g = DOUBLEP(data);
// TODO: Calculate fit
const int sizex = ceil(cutoff);
const int sizey = ceil(cutoff);
const int sizez = ceil(cutoff);
// Allocate X-matrix and b-vector
int source_points = (2*sizex+1)*(2*sizey+1)*(2*sizez+1);
double* X = GPAW_MALLOC(double, coeffs*source_points);
double* b = GPAW_MALLOC(double, source_points);
double* work = GPAW_MALLOC(double, coeffs*source_points);
// The multipliers for each dimension
int ldx = data->dimensions[1]*data->dimensions[2];
int ldy = data->dimensions[2];
int ldz = 1;
// For each point to be interpolated
for (int p=0; p< points; p++)
{
double x = (*coord_nc++)*grid_points[0] - grid_start[0];
double y = (*coord_nc++)*grid_points[1] - grid_start[0];
double z = (*coord_nc++)*grid_points[2] - grid_start[0];
// The grid center point
int cx2 = round(x);
int cy2 = round(y);
int cz2 = round(z);
// Scaled to grid
int cx = safemod(cx2,data->dimensions[0]);
int cy = safemod(cy2,data->dimensions[1]);
int cz = safemod(cz2,data->dimensions[2]);
double* i_X = X;
double* i_b = b;
// For each point to take into account
for (int dx=-sizex;dx<=sizex;dx++)
for (int dy=-sizey;dy<=sizey;dy++)
for (int dz=-sizez;dz<=sizez;dz++)
{
// Coordinates centered on x,y,z
double sx = (cx2 + dx) - x;
double sy = (cy2 + dy) - y;
double sz = (cz2 + dz) - z;
// Normalized distance from center
double d = sqrt(sx*sx+sy*sy+sz*sz) / cutoff;
double w = 0.0;
if (d < 1)
{
w = (1-d)*(1-d);
w*=w;
w*=(4*d+1);
}
//double w = exp(-d*d);
*i_X++ = w*1.0;
*i_X++ = w*sx;
*i_X++ = w*sy;
*i_X++ = w*sz;
if (order > 1)
{
*i_X++ = w*sx*sy;
*i_X++ = w*sy*sz;
*i_X++ = w*sz*sx;
*i_X++ = w*sx*sx;
*i_X++ = w*sy*sy;
*i_X++ = w*sz*sz;
}
if (order > 2)
{
*i_X++ = w*sx*sy*sz; // xyz
*i_X++ = w*sx*sx*sx; // xxx
*i_X++ = w*sy*sy*sy; // yyy
*i_X++ = w*sz*sz*sz; // zzz
*i_X++ = w*sx*sx*sy; // xxy
*i_X++ = w*sx*sx*sz; // xxz
*i_X++ = w*sy*sy*sx; // yyx
*i_X++ = w*sy*sy*sz; // yyz
*i_X++ = w*sz*sz*sx; // zzx
*i_X++ = w*sz*sz*sy; // zzy
}
*i_b++ = w*data_g[ safemod(cx+dx, data->dimensions[0]) * ldx +
safemod(cy+dy, data->dimensions[1]) * ldy +
safemod(cz+dz, data->dimensions[2]) * ldz ];
}
int info = 0;
int rhs = 1;
int worksize = coeffs*source_points;
int ldb = source_points;
dgels_("T",
&coeffs, // ...times 4.
&source_points, // lhs is of size sourcepoints...
&rhs, // one rhs.
X, // provide lhs
&coeffs, // Leading dimension of X
b, // provide rhs
&ldb, // Leading dimension of b
work, // work array (and output)
&worksize, // the size of work array
&info); // info
if (info != 0)
printf("WARNING: dgels returned %d!", info);
// Evaluate the polynomial
// Due to centered coordinates, it's just the constant term
double value = b[0];
*target_n++ = value;
//Nearest neighbour
//double value = data_g[ cx*data->dimensions[1]*data->dimensions[2] + cy*data->dimensions[2] + cz ];
//printf("%.5f" , value);
}
free(work);
free(b);
free(X);
Py_RETURN_NONE;
}
/* Subroutine */ int ddrvls_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nns, integer *nsval, integer *
nnb, integer *nbval, integer *nxval, doublereal *thresh, logical *
tsterr, doublereal *a, doublereal *copya, doublereal *b, doublereal *
copyb, doublereal *c__, doublereal *s, doublereal *copys, doublereal *
work, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 TRANS='\002,a1,\002', M=\002,i5,\002, N"
"=\002,i5,\002, NRHS=\002,i4,\002, NB=\002,i4,\002, type\002,i2"
",\002, test(\002,i2,\002)=\002,g12.5)";
static char fmt_9998[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, NRHS="
"\002,i4,\002, NB=\002,i4,\002, type\002,i2,\002, test(\002,i2"
",\002)=\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal), log(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer info;
static char path[3];
static integer rank, nrhs, nlvl, nrun, i__, j, k;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer m, n;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static integer nfail, iseed[4];
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static integer crank;
extern /* Subroutine */ int dgels_(char *, integer *, integer *, integer *
, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *);
static integer irank;
static doublereal rcond;
extern doublereal dasum_(integer *, doublereal *, integer *);
static integer itran, mnmin, ncols;
static doublereal norma, normb;
extern doublereal dqrt12_(integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dqrt14_(char *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *), dqrt17_(char *,
integer *, integer *, integer *, integer *, doublereal *, integer
*, doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static char trans[1];
static integer nerrs, itype;
extern /* Subroutine */ int dqrt13_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
static integer lwork;
extern /* Subroutine */ int dqrt15_(integer *, integer *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), dqrt16_(char *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
static integer nrows, lwlsy, nb, im, in;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer iscale;
extern /* Subroutine */ int dgelsd_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), dlacpy_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *), dgelss_(integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, integer *), alasvm_(char *, integer *, integer *,
integer *, integer *), dgelsx_(integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *),
dgelsy_(integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *), dlarnv_(integer *, integer *,
integer *, doublereal *), derrls_(char *, integer *),
xlaenv_(integer *, integer *);
static integer ldwork;
static doublereal result[18];
static integer lda, ldb, inb;
static doublereal eps;
static integer ins;
/* Fortran I/O blocks */
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
January 3, 2000
Purpose
=======
DDRVLS tests the least squares driver routines DGELS, DGELSS, DGELSX,
DGELSY and DGELSD.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
The matrix of type j is generated as follows:
j=1: A = U*D*V where U and V are random orthogonal matrices
and D has random entries (> 0.1) taken from a uniform
distribution (0,1). A is full rank.
j=2: The same of 1, but A is scaled up.
j=3: The same of 1, but A is scaled down.
j=4: A = U*D*V where U and V are random orthogonal matrices
and D has 3*min(M,N)/4 random entries (> 0.1) taken
from a uniform distribution (0,1) and the remaining
entries set to 0. A is rank-deficient.
j=5: The same of 4, but A is scaled up.
j=6: The same of 5, but A is scaled down.
NM (input) INTEGER
The number of values of M contained in the vector MVAL.
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix row dimension M.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix column dimension N.
NNS (input) INTEGER
The number of values of NRHS contained in the vector NSVAL.
NSVAL (input) INTEGER array, dimension (NNS)
The values of the number of right hand sides NRHS.
NNB (input) INTEGER
The number of values of NB and NX contained in the
vectors NBVAL and NXVAL. The blocking parameters are used
in pairs (NB,NX).
NBVAL (input) INTEGER array, dimension (NNB)
The values of the blocksize NB.
NXVAL (input) INTEGER array, dimension (NNB)
The values of the crossover point NX.
THRESH (input) DOUBLE PRECISION
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
where MMAX is the maximum value of M in MVAL and NMAX is the
maximum value of N in NVAL.
COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
B (workspace) DOUBLE PRECISION array, dimension (MMAX*NSMAX)
where MMAX is the maximum value of M in MVAL and NSMAX is the
maximum value of NRHS in NSVAL.
COPYB (workspace) DOUBLE PRECISION array, dimension (MMAX*NSMAX)
C (workspace) DOUBLE PRECISION array, dimension (MMAX*NSMAX)
S (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
COPYS (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
WORK (workspace) DOUBLE PRECISION array,
dimension (MMAX*NMAX + 4*NMAX + MMAX).
IWORK (workspace) INTEGER array, dimension (15*NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--work;
--copys;
--s;
--c__;
--copyb;
--b;
--copya;
--a;
--nxval;
--nbval;
--nsval;
--nval;
--mval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "LS", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Epsilon");
/* Threshold for rank estimation */
rcond = sqrt(eps) - (sqrt(eps) - eps) / 2;
/* Test the error exits */
if (*tsterr) {
derrls_(path, nout);
}
/* Print the header if NM = 0 or NN = 0 and THRESH = 0. */
if ((*nm == 0 || *nn == 0) && *thresh == 0.) {
alahd_(nout, path);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
xlaenv_(&c__9, &c__25);
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = max(1,m);
ldb = max(i__3,n);
i__3 = *nns;
for (ins = 1; ins <= i__3; ++ins) {
nrhs = nsval[ins];
/* Computing MAX
Computing MAX */
d__1 = 1., d__2 = (doublereal) mnmin;
i__4 = (integer) (log(max(d__1,d__2) / 26.) / log(2.)) + 1;
nlvl = max(i__4,0);
/* Computing MAX */
i__4 = 1, i__5 = (m + nrhs) * (n + 2), i__4 = max(i__4,i__5),
i__5 = (n + nrhs) * (m + 2), i__4 = max(i__4,i__5),
i__5 = m * n + (mnmin << 2) + max(m,n), i__4 = max(
i__4,i__5), i__5 = mnmin * 12 + mnmin * 50 + (mnmin <<
3) * nlvl + mnmin * nrhs + 676;
lwork = max(i__4,i__5);
for (irank = 1; irank <= 2; ++irank) {
for (iscale = 1; iscale <= 3; ++iscale) {
itype = (irank - 1) * 3 + iscale;
if (! dotype[itype]) {
goto L110;
}
if (irank == 1) {
/* Test DGELS
Generate a matrix of scaling type ISCALE */
dqrt13_(&iscale, &m, &n, ©a[1], &lda, &norma,
iseed);
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
xlaenv_(&c__3, &nxval[inb]);
for (itran = 1; itran <= 2; ++itran) {
if (itran == 1) {
*(unsigned char *)trans = 'N';
nrows = m;
ncols = n;
} else {
*(unsigned char *)trans = 'T';
nrows = n;
ncols = m;
}
ldwork = max(1,ncols);
/* Set up a consistent rhs */
if (ncols > 0) {
i__5 = ncols * nrhs;
dlarnv_(&c__2, iseed, &i__5, &work[1])
;
i__5 = ncols * nrhs;
d__1 = 1. / (doublereal) ncols;
dscal_(&i__5, &d__1, &work[1], &c__1);
}
dgemm_(trans, "No transpose", &nrows, &
nrhs, &ncols, &c_b24, ©a[1], &
lda, &work[1], &ldwork, &c_b25, &
b[1], &ldb)
;
dlacpy_("Full", &nrows, &nrhs, &b[1], &
ldb, ©b[1], &ldb);
/* Solve LS or overdetermined system */
if (m > 0 && n > 0) {
dlacpy_("Full", &m, &n, ©a[1], &
lda, &a[1], &lda);
dlacpy_("Full", &nrows, &nrhs, ©b[
1], &ldb, &b[1], &ldb);
}
s_copy(srnamc_1.srnamt, "DGELS ", (ftnlen)
6, (ftnlen)6);
dgels_(trans, &m, &n, &nrhs, &a[1], &lda,
&b[1], &ldb, &work[1], &lwork, &
info);
if (info != 0) {
alaerh_(path, "DGELS ", &info, &c__0,
trans, &m, &n, &nrhs, &c_n1, &
nb, &itype, &nfail, &nerrs,
nout);
}
/* Check correctness of results */
ldwork = max(1,nrows);
if (nrows > 0 && nrhs > 0) {
dlacpy_("Full", &nrows, &nrhs, ©b[
1], &ldb, &c__[1], &ldb);
}
dqrt16_(trans, &m, &n, &nrhs, ©a[1], &
lda, &b[1], &ldb, &c__[1], &ldb, &
work[1], result);
if (itran == 1 && m >= n || itran == 2 &&
m < n) {
/* Solving LS system */
result[1] = dqrt17_(trans, &c__1, &m,
&n, &nrhs, ©a[1], &lda, &
b[1], &ldb, ©b[1], &ldb, &
c__[1], &work[1], &lwork);
} else {
/* Solving overdetermined system */
result[1] = dqrt14_(trans, &m, &n, &
nrhs, ©a[1], &lda, &b[1],
&ldb, &work[1], &lwork);
}
/* Print information about the tests that
did not pass the threshold. */
for (k = 1; k <= 2; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&m, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&nrhs, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nb, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&itype, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k -
1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L20: */
}
nrun += 2;
/* L30: */
}
/* L40: */
}
}
/* Generate a matrix of scaling type ISCALE and rank
type IRANK. */
dqrt15_(&iscale, &irank, &m, &n, &nrhs, ©a[1], &
lda, ©b[1], &ldb, ©s[1], &rank, &
norma, &normb, iseed, &work[1], &lwork);
/* workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
Initialize vector IWORK. */
i__4 = n;
for (j = 1; j <= i__4; ++j) {
iwork[j] = 0;
/* L50: */
}
ldwork = max(1,m);
/* Test DGELSX
DGELSX: Compute the minimum-norm solution X
to min( norm( A * X - B ) ) using a complete
orthogonal factorization. */
dlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &lda);
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1], &
ldb);
s_copy(srnamc_1.srnamt, "DGELSX", (ftnlen)6, (ftnlen)
6);
dgelsx_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
iwork[1], &rcond, &crank, &work[1], &info);
if (info != 0) {
alaerh_(path, "DGELSX", &info, &c__0, " ", &m, &n,
&nrhs, &c_n1, &nb, &itype, &nfail, &
nerrs, nout);
}
/* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS )
Test 3: Compute relative error in svd
workspace: M*N + 4*MIN(M,N) + MAX(M,N) */
result[2] = dqrt12_(&crank, &crank, &a[1], &lda, &
copys[1], &work[1], &lwork);
/* Test 4: Compute error in solution
workspace: M*NRHS + M */
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[1],
&ldwork);
dqrt16_("No transpose", &m, &n, &nrhs, ©a[1], &
lda, &b[1], &ldb, &work[1], &ldwork, &work[m *
nrhs + 1], &result[3]);
/* Test 5: Check norm of r'*A
workspace: NRHS*(M+N) */
result[4] = 0.;
if (m > crank) {
result[4] = dqrt17_("No transpose", &c__1, &m, &n,
&nrhs, ©a[1], &lda, &b[1], &ldb, &
copyb[1], &ldb, &c__[1], &work[1], &lwork);
}
/* Test 6: Check if x is in the rowspace of A
workspace: (M+NRHS)*(N+2) */
result[5] = 0.;
if (n > crank) {
result[5] = dqrt14_("No transpose", &m, &n, &nrhs,
©a[1], &lda, &b[1], &ldb, &work[1], &
lwork);
}
/* Print information about the tests that did not
pass the threshold. */
for (k = 3; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&itype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += 4;
/* Loop for testing different block sizes. */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
xlaenv_(&c__3, &nxval[inb]);
/* Test DGELSY
DGELSY: Compute the minimum-norm solution X
to min( norm( A * X - B ) )
using the rank-revealing orthogonal
factorization.
Initialize vector IWORK. */
i__5 = n;
for (j = 1; j <= i__5; ++j) {
iwork[j] = 0;
/* L70: */
}
/* Set LWLSY to the adequate value.
Computing MAX */
i__5 = 1, i__6 = mnmin + (n << 1) + nb * (n + 1),
i__5 = max(i__5,i__6), i__6 = (mnmin << 1)
+ nb * nrhs;
lwlsy = max(i__5,i__6);
dlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
lda);
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
&ldb);
s_copy(srnamc_1.srnamt, "DGELSY", (ftnlen)6, (
ftnlen)6);
dgelsy_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
iwork[1], &rcond, &crank, &work[1], &
lwlsy, &info);
if (info != 0) {
alaerh_(path, "DGELSY", &info, &c__0, " ", &m,
&n, &nrhs, &c_n1, &nb, &itype, &
nfail, &nerrs, nout);
}
/* Test 7: Compute relative error in svd
workspace: M*N + 4*MIN(M,N) + MAX(M,N) */
result[6] = dqrt12_(&crank, &crank, &a[1], &lda, &
copys[1], &work[1], &lwork);
/* Test 8: Compute error in solution
workspace: M*NRHS + M */
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
1], &ldwork);
dqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
&lda, &b[1], &ldb, &work[1], &ldwork, &
work[m * nrhs + 1], &result[7]);
/* Test 9: Check norm of r'*A
workspace: NRHS*(M+N) */
result[8] = 0.;
if (m > crank) {
result[8] = dqrt17_("No transpose", &c__1, &m,
&n, &nrhs, ©a[1], &lda, &b[1], &
ldb, ©b[1], &ldb, &c__[1], &work[
1], &lwork);
}
/* Test 10: Check if x is in the rowspace of A
workspace: (M+NRHS)*(N+2) */
result[9] = 0.;
if (n > crank) {
result[9] = dqrt14_("No transpose", &m, &n, &
nrhs, ©a[1], &lda, &b[1], &ldb, &
work[1], &lwork);
}
/* Test DGELSS
DGELSS: Compute the minimum-norm solution X
to min( norm( A * X - B ) )
using the SVD. */
dlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
lda);
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
&ldb);
s_copy(srnamc_1.srnamt, "DGELSS", (ftnlen)6, (
ftnlen)6);
dgelss_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
s[1], &rcond, &crank, &work[1], &lwork, &
info);
if (info != 0) {
alaerh_(path, "DGELSS", &info, &c__0, " ", &m,
&n, &nrhs, &c_n1, &nb, &itype, &
nfail, &nerrs, nout);
}
/* workspace used: 3*min(m,n) +
max(2*min(m,n),nrhs,max(m,n))
Test 11: Compute relative error in svd */
if (rank > 0) {
daxpy_(&mnmin, &c_b92, ©s[1], &c__1, &s[1]
, &c__1);
result[10] = dasum_(&mnmin, &s[1], &c__1) /
dasum_(&mnmin, ©s[1], &c__1) / (
eps * (doublereal) mnmin);
} else {
result[10] = 0.;
}
/* Test 12: Compute error in solution */
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
1], &ldwork);
dqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
&lda, &b[1], &ldb, &work[1], &ldwork, &
work[m * nrhs + 1], &result[11]);
/* Test 13: Check norm of r'*A */
result[12] = 0.;
if (m > crank) {
result[12] = dqrt17_("No transpose", &c__1, &
m, &n, &nrhs, ©a[1], &lda, &b[1],
&ldb, ©b[1], &ldb, &c__[1], &work[
1], &lwork);
}
/* Test 14: Check if x is in the rowspace of A */
result[13] = 0.;
if (n > crank) {
result[13] = dqrt14_("No transpose", &m, &n, &
nrhs, ©a[1], &lda, &b[1], &ldb, &
work[1], &lwork);
}
/* Test DGELSD
DGELSD: Compute the minimum-norm solution X
to min( norm( A * X - B ) ) using a
divide and conquer SVD.
Initialize vector IWORK. */
i__5 = n;
for (j = 1; j <= i__5; ++j) {
iwork[j] = 0;
/* L80: */
}
dlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
lda);
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
&ldb);
s_copy(srnamc_1.srnamt, "DGELSD", (ftnlen)6, (
ftnlen)6);
dgelsd_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
s[1], &rcond, &crank, &work[1], &lwork, &
iwork[1], &info);
if (info != 0) {
alaerh_(path, "DGELSD", &info, &c__0, " ", &m,
&n, &nrhs, &c_n1, &nb, &itype, &
nfail, &nerrs, nout);
}
/* Test 15: Compute relative error in svd */
if (rank > 0) {
daxpy_(&mnmin, &c_b92, ©s[1], &c__1, &s[1]
, &c__1);
result[14] = dasum_(&mnmin, &s[1], &c__1) /
dasum_(&mnmin, ©s[1], &c__1) / (
eps * (doublereal) mnmin);
} else {
result[14] = 0.;
}
/* Test 16: Compute error in solution */
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
1], &ldwork);
dqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
&lda, &b[1], &ldb, &work[1], &ldwork, &
work[m * nrhs + 1], &result[15]);
/* Test 17: Check norm of r'*A */
result[16] = 0.;
if (m > crank) {
result[16] = dqrt17_("No transpose", &c__1, &
m, &n, &nrhs, ©a[1], &lda, &b[1],
&ldb, ©b[1], &ldb, &c__[1], &work[
1], &lwork);
}
/* Test 18: Check if x is in the rowspace of A */
result[17] = 0.;
if (n > crank) {
result[17] = dqrt14_("No transpose", &m, &n, &
nrhs, ©a[1], &lda, &b[1], &ldb, &
work[1], &lwork);
}
/* Print information about the tests that did not
pass the threshold. */
for (k = 7; k <= 18; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&itype, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L90: */
}
nrun += 12;
/* L100: */
}
L110:
;
}
/* L120: */
}
/* L130: */
}
/* L140: */
}
/* L150: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DDRVLS */
} /* ddrvls_ */
int main ( int argc, char * argv[]) {
double **x, **y;
double R[N][N], T[N];
double Q[N][N], tau[N];
double rQ[N][N], rQnew[N][N], H[N][N], v[N];
char pdbname1 [150] = "\0";
char pdbname2 [150] = "\0";
char pdbid1 [50] = "\0"; /* this might be too restrictive */
char pdbid2 [50] = "\0";
char filename [150] = "\0";
int component, ctr;
int no_vectors;
int h, i, j, k;
double sum = 0;
Residue * sequence_new;
int read_pdb ( char * pdbname, Residue ** sequence, int *no_res);
void dgels_ (char * trans, int * no_rows, int * no_columns, int * ,
double ** scratch, int *,
double **A, int *, double * work, int * lwork, int *info);
void dgeqrf_ (int *M, int *, double **A, int *LDA, double * TAU,
double * WORK, int * LWORK, int *INFO );
int calphas_to_XY ( double *** x, double ***y, char * name_x,
char *name_y, int * no_matching_residues);
int transform (double tfm_matrix[][N], double * transl_vector,
Residue * seqeunce, int no_res, Residue * seqeunce_new);
int pdb_output ( char *filename, Residue * sequence_new, int no_res);
if ( argc < 2 ) {
printf ( "Usage: %s <pdbname1> <pdbname2>.\n", argv[0] );
printf ( "(To transform <pdbname1> into <pdbname2>;");
printf ( " the alignment btw the two pdb files assumed).\n");
exit (1);
}
sprintf ( pdbname1, "%s", argv[1]);
sprintf ( pdbname2, "%s", argv[2]);
memcpy (pdbid1, pdbname1, strlen (pdbname1) - 4); /* get rid of the pdb extension */
memcpy (pdbid2, pdbname2, strlen (pdbname2) - 4);
/* input two pdbs */
if ( read_pdb ( pdbname1, &sequence1, &no_res_1)) exit (1);
if ( read_pdb ( pdbname2, &sequence2, &no_res_2)) exit (1);
/* turn the matching atoms into vectors x and y - use only c-alphas*/
calphas_to_XY ( &x, &y, pdbid1, pdbid2, &no_vectors);
/* check: */
if (0) {
printf (" Number of vectors read in: %d. \n", no_vectors);
for ( ctr =0; ctr < no_vectors; ctr++ ) {
printf ("\t x%1d %10.4lf %10.4lf %10.4lf ",
ctr, x[0][ctr], x[1][ctr], x[2][ctr]);
printf ("\t y%1d %10.4lf %10.4lf %10.4lf \n",
ctr, y[0][ctr], y[1][ctr], y[2][ctr]);
}
}
exit (1);
/* make the fourth component of x equal to 1 - a trick to incorporate translation into A */
for (ctr =0; ctr < no_vectors; ctr++) x[3][ctr] = 1.0;
/* solve the least squares problem - use the nomenclature from dgels */
char trans= 'N';
int info;
int lwork = 2*no_vectors;
double work [2*no_vectors];
int n = N;
double A[N+1][no_vectors];
int no_rows = no_vectors, no_columns = N+1;
int lead_dim_A = no_vectors;
double B[N][no_vectors];
int lead_dim_B = no_vectors;
memcpy (A[0], x[0], (N+1)*no_vectors*sizeof(double));
memcpy (B[0], y[0], N*no_vectors*sizeof(double));
dgels_ ( &trans, &no_rows, &no_columns, &n, &A, &lead_dim_A,
&B, &lead_dim_B, work, &lwork, &info);
printf (" info: %d\n", info);
printf ("******************************************************\n");
printf (" solution: \n" );
for ( ctr =0; ctr < N; ctr++ ) {
for ( component=0; component<N+1; component++) {
printf ("%10.3lf", B[ctr][component]);
}
printf ("\n");
}
printf ("\n");
printf ("******************************************************\n");
/* rotation and translation parts*/
for ( i =0; i < N; i++ ) {
for ( j =0; j < N; j++ ) {
R[i][j] = B[i][j];
}
T[i] = B[i][N];
}
/* rotate and translate the first chain */
sequence_new = emalloc ( no_res_1 * sizeof(Residue));
memcpy ( sequence_new, sequence1, no_res_1 * sizeof(Residue));
transform ( R, T, sequence1, no_res_1, sequence_new );
/* output the transformed chain */
sprintf (filename, "%s", "transformed.pdb");
pdb_output ( filename, sequence_new, no_res_1);
/* is the solution orthogonal? */
printf (" orthogonal?\n" );
for ( i =0; i < N; i++ ) {
for ( j =0; j < N; j++ ) {
sum = 0.0;
for ( component=0; component<N; component++) {
sum += R[i][component]*R[j][component];
}
printf ("%10.3lf", sum);
}
printf ("\n");
}
printf ("\n");
printf ("******************************************************\n");
/* no reason to believe it will be orthogonal, so orthogonalize using QR decomp: */
/* find decomposition: */
for ( i =0; i < N; i++ ) {
for ( j =0; j < N; j++ ) {
Q[i][j] = B[j][i];
}
}
n = N;
dgeqrf_ ( &n, &n, &Q, &n, tau, work, &lwork, &info);
if ( info ) {
fprintf ( stderr, "Error running dgeqrf. Info: %d.\n", info);
exit (1);
}
/* reconstruct Q: */
/*extract R*/
for ( i =0; i < n; i++ ) {
for ( j =0; j < i; j++ ) {
R[i][j] = 0.0;
}
for ( j =i; j < n; j++ ) {
R[i][j] = Q[j][i];
}
}
/* reconstruct Q (I could not get the orginal LAPACK function to work: */
memset( rQ[0], 0, n*n*sizeof(double));
rQ[0][0] = rQ[1][1] = rQ[2][2] = 1.0;
for ( h =0; h < n; h++ ) {
/* find vh*/
for ( i=0; i<h; i++ ) v[i] = 0.0;
v[h] = 1.0;
for ( i=h+1; i<n; i++ ) v[i] = Q[h][i];
/* find Hh */
for ( i =0; i < n; i++ ) {
H[i][i] = 1.0 -tau[h]*v[i]*v[i];
for ( j =i+1; j < n; j++ ) {
H[i][j] = H[j][i] = -tau[h]*v[i]*v[j];
}
}
/* multiply rQ by Hi */
for ( i =0; i < n; i++ ) {
for ( j =0; j < n; j++ ) {
rQnew[i][j] = 0.0;
for ( k =0; k < n; k++ ) {
rQnew[i][j] += rQ[i][k]*H[k][j];
}
}
}
memcpy ( rQ[0], rQnew[0], n*n*sizeof(double));
}
/* to get as close as possible to the original matrix, require that diagonals
in R be positive (in the limiting case when the input matrix is already
orthogonal, R should be I */
for ( i =0; i < n; i++ ) {
if ( R[i][i] < 0 ) {
for ( j =0; j < n; j++ ) {
rQ[j][i] *= -1;
R [i][j] *= -1;
}
}
}
printf ("Q reconstructed \n");
for ( i =0; i < n; i++ ) {
for ( j =0; j < n; j++ ) {
printf ("%10.3lf", rQ[i][j]);
}
printf ("\n");
}
printf ("\n");
printf ("******************************************************\n");
printf ("R: \n");
for ( i =0; i < n; i++ ) {
for ( j =0; j < n; j++ ) {
printf ("%10.3lf", R[i][j]);
}
printf ("\n");
}
printf ("\n");
printf ("******************************************************\n");
printf ("final orthogonality\n");
for ( i =0; i < n; i++ ) {
for ( j =0; j < n; j++ ) {
sum = 0.0;
for ( component=0; component<n; component++) {
sum += rQ[component][i]*rQ[component][j];
}
printf ("%10.3lf", sum);
}
printf ("\n");
}
printf ("\n");
printf ("******************************************************\n");
printf ("QRproduct\n");
for ( i =0; i < n; i++ ) {
for ( j =0; j < n; j++ ) {
sum = 0.0;
for ( component=0; component<n; component++) {
sum += rQ[i][component]*R[component][j];
}
printf ("%10.3lf", sum);
}
printf ("\n");
}
printf ("\n");
printf ("******************************************************\n");
/* rotate and translate the first chain */
memcpy ( sequence_new, sequence1, no_res_1 * sizeof(Residue));
transform ( rQ, T, sequence1, no_res_1, sequence_new );
/* output the transformed chain */
sprintf (filename, "%s", "rotated.pdb");
pdb_output ( filename, sequence_new, no_res_1);
return 0;
}
/* Subroutine */ int derrls_(char *path, integer *nunit)
{
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublereal a[4] /* was [2][2] */, b[4] /* was [2][2] */, s[2], w[2];
char c2[2];
integer ip[2], info, irnk;
extern /* Subroutine */ int dgels_(char *, integer *, integer *, integer *
, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *);
doublereal rcond;
extern /* Subroutine */ int alaesm_(char *, logical *, integer *),
dgelsd_(integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int dgelss_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *),
chkxer_(char *, integer *, integer *, logical *, logical *), dgelsx_(integer *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *), dgelsy_(integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DERRLS tests the error exits for the DOUBLE PRECISION least squares */
/* driver routines (DGELS, SGELSS, SGELSX, SGELSY, SGELSD). */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
a[0] = 1.;
a[2] = 2.;
a[3] = 3.;
a[1] = 4.;
infoc_1.ok = TRUE_;
if (lsamen_(&c__2, c2, "LS")) {
/* Test error exits for the least squares driver routines. */
/* DGELS */
s_copy(srnamc_1.srnamt, "DGELS ", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgels_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
chkxer_("DGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgels_("N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
chkxer_("DGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgels_("N", &c__0, &c_n1, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
chkxer_("DGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgels_("N", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, w, &c__1, &info);
chkxer_("DGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dgels_("N", &c__2, &c__0, &c__0, a, &c__1, b, &c__2, w, &c__2, &info);
chkxer_("DGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dgels_("N", &c__2, &c__0, &c__0, a, &c__2, b, &c__1, w, &c__2, &info);
chkxer_("DGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dgels_("N", &c__1, &c__1, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
chkxer_("DGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGELSS */
s_copy(srnamc_1.srnamt, "DGELSS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgelss_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
&c__1, &info);
chkxer_("DGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgelss_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
&c__1, &info);
chkxer_("DGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgelss_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
&c__1, &info);
chkxer_("DGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgelss_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, s, &rcond, &irnk, w,
&c__2, &info);
chkxer_("DGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgelss_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, s, &rcond, &irnk, w,
&c__2, &info);
chkxer_("DGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGELSX */
s_copy(srnamc_1.srnamt, "DGELSX", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgelsx_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
&info);
chkxer_("DGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgelsx_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
&info);
chkxer_("DGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgelsx_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
&info);
chkxer_("DGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgelsx_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, ip, &rcond, &irnk, w,
&info);
chkxer_("DGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgelsx_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, ip, &rcond, &irnk, w,
&info);
chkxer_("DGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGELSY */
s_copy(srnamc_1.srnamt, "DGELSY", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgelsy_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
&c__10, &info);
chkxer_("DGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgelsy_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
&c__10, &info);
chkxer_("DGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgelsy_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
&c__10, &info);
chkxer_("DGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgelsy_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, ip, &rcond, &irnk, w,
&c__10, &info);
chkxer_("DGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgelsy_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, ip, &rcond, &irnk, w,
&c__10, &info);
chkxer_("DGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
dgelsy_(&c__2, &c__2, &c__1, a, &c__2, b, &c__2, ip, &rcond, &irnk, w,
&c__1, &info);
chkxer_("DGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGELSD */
s_copy(srnamc_1.srnamt, "DGELSD", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgelsd_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
&c__10, ip, &info);
chkxer_("DGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgelsd_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
&c__10, ip, &info);
chkxer_("DGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgelsd_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
&c__10, ip, &info);
chkxer_("DGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgelsd_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, s, &rcond, &irnk, w,
&c__10, ip, &info);
chkxer_("DGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgelsd_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, s, &rcond, &irnk, w,
&c__10, ip, &info);
chkxer_("DGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
dgelsd_(&c__2, &c__2, &c__1, a, &c__2, b, &c__2, s, &rcond, &irnk, w,
&c__1, ip, &info);
chkxer_("DGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of DERRLS */
} /* derrls_ */
