template <typename fptype> static inline int
lapack_SVD(fptype* a, size_t a_step, fptype *w, fptype* u, size_t u_step, fptype* vt, size_t v_step, int m, int n, int flags, int* info)
{
int lda = a_step / sizeof(fptype);
int ldv = v_step / sizeof(fptype);
int ldu = u_step / sizeof(fptype);
int lwork = -1;
int* iworkBuf = new int[8*std::min(m, n)];
fptype work1 = 0;
//A already transposed and m>=n
char mode[] = { ' ', '\0'};
if(flags & CV_HAL_SVD_NO_UV)
{
ldv = 1;
mode[0] = 'N';
}
else if((flags & CV_HAL_SVD_SHORT_UV) && (flags & CV_HAL_SVD_MODIFY_A)) //short SVD, U stored in a
mode[0] = 'O';
else if((flags & CV_HAL_SVD_SHORT_UV) && !(flags & CV_HAL_SVD_MODIFY_A)) //short SVD, U stored in u if m>=n
mode[0] = 'S';
else if(flags & CV_HAL_SVD_FULL_UV) //full SVD, U stored in u or in a
mode[0] = 'A';
if((flags & CV_HAL_SVD_MODIFY_A) && (flags & CV_HAL_SVD_FULL_UV)) //U stored in a
{
u = new fptype[m*m];
ldu = m;
}
if(typeid(fptype) == typeid(float))
sgesdd_(mode, &m, &n, (float*)a, &lda, (float*)w, (float*)u, &ldu, (float*)vt, &ldv, (float*)&work1, &lwork, iworkBuf, info);
else if(typeid(fptype) == typeid(double))
dgesdd_(mode, &m, &n, (double*)a, &lda, (double*)w, (double*)u, &ldu, (double*)vt, &ldv, (double*)&work1, &lwork, iworkBuf, info);
lwork = round(work1); //optimal buffer size
fptype* buffer = new fptype[lwork + 1];
if(typeid(fptype) == typeid(float))
sgesdd_(mode, &m, &n, (float*)a, &lda, (float*)w, (float*)u, &ldu, (float*)vt, &ldv, (float*)buffer, &lwork, iworkBuf, info);
else if(typeid(fptype) == typeid(double))
dgesdd_(mode, &m, &n, (double*)a, &lda, (double*)w, (double*)u, &ldu, (double*)vt, &ldv, (double*)buffer, &lwork, iworkBuf, info);
if(!(flags & CV_HAL_SVD_NO_UV))
transpose_square_inplace(vt, ldv, n);
if((flags & CV_HAL_SVD_MODIFY_A) && (flags & CV_HAL_SVD_FULL_UV))
{
for(int i = 0; i < m; i++)
for(int j = 0; j < m; j++)
a[i*lda + j] = u[i*m + j];
delete[] u;
}
delete[] iworkBuf;
delete[] buffer;
return CV_HAL_ERROR_OK;
}
int svdd(double **a, int m, int n, double *d, double **u, double **v)
{
double *A, *U, *VT;
int lwork = -1;
int liwork = 8*MIN(m,n);
char jobz = 'S';
double dw,*work=&dw; /*points to a temporary cell*/
int *iwork;
int i, j, k, info,minmn=MIN(m,n);
MAKE_VECTOR(A, m*n);
for (j=0, k=0; j<n; j++) {
for (i=0; i<m; i++) A[k++] = a[i][j];
}
MAKE_VECTOR(U, m*minmn);
MAKE_VECTOR(VT,minmn*n);
MAKE_VECTOR(iwork, liwork);
lwork=-1;
dgesdd_(&jobz, &m, &n, A, &m, d, U, &m, VT, &n,
work, &lwork, iwork, &info); /*call to get optimal lwork*/
if (info!=0) {
//WCC printf("error: allocating LWORK in svdd\n");
//WCC exit(1);
error("error: allocating LWORK in svdd\n");
}
lwork=(int)*work;
MAKE_VECTOR(work, lwork);
dgesdd_(&jobz, &m, &n, A, &m, d, U, &m, VT, &minmn,
work, &lwork, iwork, &info);
FREE_VECTOR(A);
FREE_VECTOR(work);
FREE_VECTOR(iwork);
for (j=0, k=0; j<minmn; j++) {
for (i=0; i<m; i++) u[i][j]=U[k++];
}
/* VT, as calculated by dgesdd_(), is the transpose of the right
* multiplier. Here we undo the transpose so that the matrix
* v[][] returned by this function is not transposed anymore.
*/
for (i=0,k=0; i<n; i++) {
for (j=0; j<minmn; j++) v[i][j]=VT[k++];
}
FREE_VECTOR(U);
FREE_VECTOR(VT);
return info;
}
int gsl_clapack_dgesdd_(gsl_matrix *mtrxA, gsl_matrix *mtrxU, gsl_vector *vecS, gsl_matrix *mtrxV) {
int works = 0;
int M = mtrxA->size1;
int N = mtrxA->size2;
double *A = (double*) malloc(sizeof(double)*M*N);
memcpy(A, mtrxA->data, N*M);
char jobz = 'S';
int lda = max(1, M);
int ldu = max(M, N);
int ldvt = min(M, N);
double *s = vecS->data;
int lwork = 4*min(M,N) + max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N));
int *iwork = malloc(sizeof(int)*8*max(M, N));
double *wk = malloc(sizeof(double)*lwork);
double *uu = mtrxU->data;
double *vt = mtrxV->data;
int info;
if (dgesdd_(&jobz, &M, &N, A, &lda, s, uu, &ldu, vt, &ldvt, wk, &lwork, iwork, &info) == 1)
works = 1;
free(wk);
free(iwork);
free(A);
return works;
}
bool svd_lapack(int n, vector_t & A, vector_t & S, matrix_t & V)
{
int m=n;
vector_t U(n*n);
vector_t tV(n*n);
cout << "Using LAPACK SVD library function...\n";
#ifdef WITH_LAPACK
int info=0;
vector<int> iwork(8*m,0);
double optim_lwork;
int lwork;
lwork = -1;
// Determine workspace needed
dgesdd_("A", &m, &n, &A[0] , &m, &S[0], &U[0], &m, &tV[0], &n, &optim_lwork, &lwork, &iwork[0], &info);
lwork = (int) optim_lwork;
vector_t work( lwork, 0 );
// Perform actual SVD
dgesdd_("A", &m, &n, &A[0] , &m, &S[0], &U[0], &m, &tV[0], &n, &work[0], &lwork, &iwork[0], &info);
// Copy and transpose V
int k = 0;
for( int i = 0; i < n; i++ )
for( int j = 0; j < n; j++ )
{
V[j][i] = tV[k];
++k;
}
return true;
#else
// LAPACK support not compiled
return false;
#endif
}
void dgesvd(double **A, int M, int N, double *S, double **U, double **VT)
{
char jobu, jobvt;
int m=M, n=N ,lda=N, ldu=M, ldvt=N;
double *a, *s, *u, *vt;
int lwork, info;
double wkopt;
double *work;
int *iwork = new int[8*N];
a = new double [M*N];
u = new double [M*M];
vt = new double [N*N];
a = dgesvd_ctof(A, lda, n); /* Convert the matrix A from double pointer
C form to single pointer Fortran form. */
lwork = -1;
dgesdd_( "O", &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, &wkopt, &lwork, iwork, &info );
lwork = (int)wkopt;
work = (double*)malloc( lwork*sizeof(double) );
/* Compute SVD */
dgesdd_( "O", &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, iwork, &info );
dgesvd_ftoc(u, U, ldu, ldu);
dgesvd_ftoc(vt, VT, ldvt, n);
delete a;
delete u;
delete vt;
delete iwork;
delete work;
}
int
mad_mat_svd (const num_t x[], num_t u[], num_t s[], num_t v[], ssz_t m, ssz_t n)
{
assert( x && u && s && v );
int info=0;
const int nm=m, nn=n;
num_t sz;
int lwork=-1;
int iwk[8*MIN(m,n)];
mad_alloc_tmp(num_t, ra, m*n);
mad_mat_trans(x, ra, m, n);
dgesdd_("A", &nm, &nn, ra, &nm, s, u, &nm, v, &nn, &sz, &lwork, iwk, &info); // query
mad_alloc_tmp(num_t, wk, lwork=sz);
dgesdd_("A", &nm, &nn, ra, &nm, s, u, &nm, v, &nn, wk, &lwork, iwk, &info); // compute
mad_free_tmp(wk); mad_free_tmp(ra);
mad_mat_trans(u, u, m, m);
if (info < 0) error("invalid input argument");
if (info > 0) warn ("SVD failed to converged");
return info;
}
void vector_dgesvd(double *A, int M, int N)
{
char jobu, jobvt;
int m=M, n=N ,lda=N, ldu=M, ldvt=N;
double *a, *s, *u, *vt;
int lwork, info;
double wkopt;
double *work;
int *iwork = new int[8*N];
vt = new double [N*N];
s = new double[N];
jobu = 'O'; /* Specifies options for computing U.
A: all M columns of U are returned in array U;
S: the first min(m,n) columns of U (the left
singular vectors) are returned in the array U;
O: the first min(m,n) columns of U (the left
singular vectors) are overwritten on the array A;
N: no columns of U (no left singular vectors) are
computed. */
lwork = -1;
dgesdd_( "O", &m, &n, A, &ldu, s, u, &ldu, vt, &ldvt, &wkopt, &lwork, iwork, &info );
lwork = (int)wkopt;
work = (double*)malloc( lwork*sizeof(double) );
/* Compute SVD */
dgesdd_( "O", &m, &n, A, &ldu, s, u, &ldu, vt, &ldvt, work, &lwork, iwork, &info );
delete vt;
delete s;
delete iwork;
delete work;
}
void mexFunction(
int nlhs, mxArray *plhs[],
int nrhs, const mxArray *prhs[] )
{ double *A, *U, *V, *VT, *S, *flag, *work, *AA;
ptrdiff_t *irS, *jcS, *iwork;
ptrdiff_t M, N, lwork, info, options, minMN, maxMN, k, j;
ptrdiff_t LDA, LDU, LDVT, nU, mVT, mS, nS;
char *jobz;
/* CHECK FOR PROPER NUMBER OF ARGUMENTS */
if (nrhs > 2){
mexErrMsgTxt("mexsvd: requires at most 2 input arguments."); }
if (nlhs > 4){
mexErrMsgTxt("mexsvd: requires at most 4 output argument."); }
/* CHECK THE DIMENSIONS */
M = mxGetM(prhs[0]);
N = mxGetN(prhs[0]);
if (mxIsSparse(prhs[0])) {
mexErrMsgTxt("mexeig: sparse matrix not allowed."); }
A = mxGetPr(prhs[0]);
LDA = M;
minMN = MIN(M,N);
maxMN = MAX(M,N);
options = 0;
if (nrhs==2) { options = (ptrdiff_t)*mxGetPr(prhs[1]); }
if (options==0) {
/***** economical SVD ******/
jobz="S"; nU = minMN; mVT = minMN; mS = minMN; nS = minMN;
} else {
/***** full SVD ******/
jobz="A"; nU = M; mVT = N; mS = M; nS = N;
}
LDU = M;
LDVT = mVT;
/***** create return argument *****/
if (nlhs >=3) {
/***** compute singular values and vectors ******/
plhs[0] = mxCreateDoubleMatrix(M,nU,mxREAL);
U = mxGetPr(plhs[0]);
plhs[1] = mxCreateSparse(mS,nS,minMN,mxREAL);
S = mxGetPr(plhs[1]);
irS = mxGetIr(plhs[1]);
jcS = mxGetJc(plhs[1]);
plhs[2] = mxCreateDoubleMatrix(N,mVT,mxREAL);
V = mxGetPr(plhs[2]);
plhs[3] = mxCreateDoubleMatrix(1,1,mxREAL);
flag = mxGetPr(plhs[3]);
} else {
/***** compute only singular values ******/
plhs[0]= mxCreateDoubleMatrix(minMN,1,mxREAL);
S = mxGetPr(plhs[0]);
plhs[1] = mxCreateDoubleMatrix(1,1,mxREAL);
flag = mxGetPr(plhs[1]);
U = mxCalloc(M*nU,sizeof(double));
V = mxCalloc(N*mVT,sizeof(double));
jobz="N";
}
/***** Do the computations in a subroutine *****/
lwork = 4*minMN*minMN + MAX(maxMN,5*minMN*minMN+4*minMN);
work = mxCalloc(lwork,sizeof(double));
iwork = mxCalloc(8*minMN,sizeof(ptrdiff_t));
VT = mxCalloc(mVT*N,sizeof(double));
AA = mxCalloc(M*N,sizeof(double));
memcpy(AA,mxGetPr(prhs[0]),(M*N)*sizeof(double));
dgesdd_(jobz,&M,&N, AA,&LDA,S,U,&LDU,VT,&LDVT,work,&lwork,iwork, &info);
flag[0] = (double)info;
if (nlhs >= 3) {
for (k=0; k<minMN; k++) { irS[k] = k; }
jcS[0] = 0;
for (k=1; k<=nS; k++) {
if (k<minMN) { jcS[k] = k; } else { jcS[k] = minMN; }
}
for (k=0; k<mVT; k++) {
for (j=0; j<N; j++) { V[j+k*N] = VT[k+j*mVT]; }
}
}
return;
}
int rigid(double ** W, /* D+1 x D | Linear map */
double ** T, /* M x D | Moved points */
double ** P, /* M+1 x N+1 | Matching probablity */
double *** C, /* 4 x max(M,N) x D | Working memory */
double * S, /* nlp x M x D | Working wemory (3D) */
const double ** X, /* N x D | Point set 1 (Data) */
const double ** Y, /* M x D | Point set 2 (Data) */
const int size[3], /* M, N, D | D must be 2 or 3 */
const double prms[2], /* parameters: nloop, omg */
const int verb /* flag: verbose */
){
int i,j,m,n,d,M,N,D,lp,ws,wi[WSIZE]; int info; char jobz='A';
int nlp=(int)prms[0]; double omg=prms[1],reg=1e-9;
double conv,s,noise,sgm2=0,pres1=1e10,pres2=1e20,val,c1,c2;
double mX[3],mY[3],A[9],B[9],a[3],U[9],L[3],Vt[9],wd[WSIZE];
double **R,**PXc,**Xc,**Yc;
M=size[0];N=size[1];D=size[2]; assert(D<=3);
R=W;PXc=C[0];Xc=C[1];Yc=C[2];ws=WSIZE;
/* initialize */
for(d=0;d<D;d++)for(i=0;i<D;i++) R[d][i]=d==i?1:0;
for(m=0;m<M;m++)for(d=0;d<D;d++) T[m][d]=Y[m][d];
for(m=0;m<M;m++)for(n=0;n<N;n++) sgm2+=dist2(X[n],Y[m],D);sgm2/=M*N*D;
/* main computation */
for(lp=0;lp<nlp;lp++){noise=(pow(2.0*M_PI*sgm2,0.5*D)*M*omg)/(N*(1-omg));
if(S)for(m=0;m<M;m++)for(d=0;d<D;d++) S[m+d*M+lp*M*D]=T[m][d];
/* compute matching probability */
for(n=0;n<=N;n++) P[M][n]=0;
for(m=0;m<=M;m++) P[m][N]=0;
for(m=0;m< M;m++)for(n=0;n<N;n++) P[m][n]=exp(-dist2(X[n],T[m],D)/(2.0*sgm2))+reg;
for(m=0;m< M;m++)for(n=0;n<N;n++) P[M][n]+=P[m][n];
for(m=0;m<=M;m++)for(n=0;n<N;n++) P[m][n]/=P[M][n]+noise;
for(m=0;m< M;m++)for(n=0;n<N;n++) P[m][N]+=P[m][n];
for(m=0;m< M;m++) P[M][N]+=P[m][N];
/* centerize X and Y */
for(d=0;d<D;d++){mX[d]=0;for(n=0;n<N;n++) mX[d]+=X[n][d]*P[M][n];mX[d]/=P[M][N];}
for(d=0;d<D;d++){mY[d]=0;for(m=0;m<M;m++) mY[d]+=Y[m][d]*P[m][N];mY[d]/=P[M][N];}
for(n=0;n<N;n++)for(d=0;d<D;d++) Xc[n][d]=X[n][d]-mX[d];
for(m=0;m<M;m++)for(d=0;d<D;d++) Yc[m][d]=Y[m][d]-mY[d];
/* A=Xc'*P'*Yc */
for(m=0;m<M;m++)for(d=0;d<D;d++){PXc[m][d]=0;for(n=0;n<N;n++) PXc[m][d]+=P [m][n]*Xc[n][d];}
for(d=0;d<D;d++)for(i=0;i<D;i++){A[d+i*D ]=0;for(m=0;m<M;m++) A[d+i*D] +=PXc[m][d]*Yc[m][i];}
for(d=0;d<D;d++)for(i=0;i<D;i++) B[d+i*D]=A[d+i*D];
/* compute svd of A and rotation matrix R */
dgesdd_(&jobz,&D,&D,B,&D,L,U,&D,Vt,&D,wd,&ws,wi,&info);
val=det(U,D)*det(Vt,D); if(val<0)for(d=0;d<D;d++)U[d+D*(D-1)]*=-1;
for(i=0;i<D;i++)for(j=0;j<D;j++){R[i][j]=0;for(d=0;d<D;d++) R[i][j]+=U[i+d*D]*Vt[d+j*D];}
/* compute scaling s and intercept a */
c1=c2=0;
for(d=0;d<D;d++)for(i=0;i<D;i++)c1+=A[d+i*D]*R[d][i];
for(d=0;d<D;d++)for(m=0;m<M;m++)c2+=SQ(Yc[m][d])*P[m][N]; s=c1/c2;
/* compute transformation T */
for(d=0;d<D;d++){val=0;for(i=0;i<D;i++)val+=R[d][i]*mY[i];a[d]=mX[d]-s*val;}
for(m=0;m<M;m++)for(d=0;d<D;d++){val=0;for(i=0;i<D;i++)val+=R[d][i]*Y[m][i];T[m][d]=s*val+a[d];}
/* compute sgm2 (corresponds to residual) */
pres2=pres1;pres1=sgm2;sgm2=-s*c1;
for(n=0;n<N;n++)for(d=0;d<D;d++) sgm2+=SQ(Xc[n][d])*P[M][n]; sgm2/=P[M][N]*D;
/* check convergence */
conv=log(pres2)-log(sgm2 );
if(verb) printOptIndex('r',lp,P[M][N],sqrt(sgm2),noise,conv);
if(fabs(conv)<1e-8)break;
}
return lp;
}
/* Subroutine */ int derred_(char *path, integer *nunit)
{
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002 passed the tests of the error exit"
"s (\002,i3,\002 tests done)\002)";
static char fmt_9998[] = "(\002 *** \002,a6,\002 failed the tests of the"
" error exits ***\002)";
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer info, sdim;
static doublereal a[16] /* was [4][4] */;
static logical b[4];
static integer i__, j;
static doublereal s[4], u[16] /* was [4][4] */, w[16];
extern /* Subroutine */ int dgees_(char *, char *, L_fp, integer *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, logical *,
integer *), dgeev_(char *, char *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *);
static doublereal abnrm;
static char c2[2];
static doublereal r1[4], r2[4];
extern /* Subroutine */ int dgesdd_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *);
static integer iw[8];
static doublereal wi[4];
static integer nt;
static doublereal vl[16] /* was [4][4] */, vr[16] /* was [4][4]
*/, wr[4], vt[16] /* was [4][4] */;
extern /* Subroutine */ int dgesvd_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *);
extern logical dslect_();
extern /* Subroutine */ int dgeesx_(char *, char *, L_fp, char *, integer
*, doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *
, integer *, integer *, integer *, logical *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int dgeevx_(char *, char *, char *, char *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *), chkxer_(char *, integer *, integer *, logical *,
logical *);
static integer ihi, ilo;
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___25 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
#define a_ref(a_1,a_2) a[(a_2)*4 + a_1 - 5]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
December 22, 1999
Purpose
=======
DERRED tests the error exits for the eigenvalue driver routines for
DOUBLE PRECISION matrices:
PATH driver description
---- ------ -----------
SEV DGEEV find eigenvalues/eigenvectors for nonsymmetric A
SES DGEES find eigenvalues/Schur form for nonsymmetric A
SVX DGEEVX SGEEV + balancing and condition estimation
SSX DGEESX SGEES + balancing and condition estimation
DBD DGESVD compute SVD of an M-by-N matrix A
DGESDD compute SVD of an M-by-N matrix A (by divide and
conquer)
Arguments
=========
PATH (input) CHARACTER*3
The LAPACK path name for the routines to be tested.
NUNIT (input) INTEGER
The unit number for output.
===================================================================== */
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);
/* Initialize A */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
a_ref(i__, j) = 0.;
/* L10: */
}
/* L20: */
}
for (i__ = 1; i__ <= 4; ++i__) {
a_ref(i__, i__) = 1.;
/* L30: */
}
infoc_1.ok = TRUE_;
nt = 0;
if (lsamen_(&c__2, c2, "EV")) {
/* Test DGEEV */
s_copy(srnamc_1.srnamt, "DGEEV ", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgeev_("X", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__1, &info);
chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgeev_("N", "X", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__1, &info);
chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgeev_("N", "N", &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__1, &info);
chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgeev_("N", "N", &c__2, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__6, &info);
chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
dgeev_("V", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &c__1, w, &
c__8, &info);
chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
dgeev_("N", "V", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &c__1, w, &
c__8, &info);
chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
dgeev_("V", "V", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__3, &info);
chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
} else if (lsamen_(&c__2, c2, "ES")) {
/* Test DGEES */
s_copy(srnamc_1.srnamt, "DGEES ", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgees_("X", "N", (L_fp)dslect_, &c__0, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__1, b, &info);
chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgees_("N", "X", (L_fp)dslect_, &c__0, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__1, b, &info);
chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgees_("N", "S", (L_fp)dslect_, &c_n1, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__1, b, &info);
chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dgees_("N", "S", (L_fp)dslect_, &c__2, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__6, b, &info);
chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
dgees_("V", "S", (L_fp)dslect_, &c__2, a, &c__2, &sdim, wr, wi, vl, &
c__1, w, &c__6, b, &info);
chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
dgees_("N", "S", (L_fp)dslect_, &c__1, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__2, b, &info);
chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 6;
} else if (lsamen_(&c__2, c2, "VX")) {
/* Test DGEEVX */
s_copy(srnamc_1.srnamt, "DGEEVX", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgeevx_("X", "N", "N", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgeevx_("N", "X", "N", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgeevx_("N", "N", "X", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgeevx_("N", "N", "N", "X", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgeevx_("N", "N", "N", "N", &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgeevx_("N", "N", "N", "N", &c__2, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
dgeevx_("N", "V", "N", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__6, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
dgeevx_("N", "N", "V", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__6, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 21;
dgeevx_("N", "N", "N", "N", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 21;
dgeevx_("N", "V", "N", "N", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__2, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 21;
dgeevx_("N", "N", "V", "V", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__3, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 11;
} else if (lsamen_(&c__2, c2, "SX")) {
/* Test DGEESX */
s_copy(srnamc_1.srnamt, "DGEESX", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgeesx_("X", "N", (L_fp)dslect_, "N", &c__0, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgeesx_("N", "X", (L_fp)dslect_, "N", &c__0, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgeesx_("N", "N", (L_fp)dslect_, "X", &c__0, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgeesx_("N", "N", (L_fp)dslect_, "N", &c_n1, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgeesx_("N", "N", (L_fp)dslect_, "N", &c__2, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__6, iw, &c__1, b, &info);
chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
dgeesx_("V", "N", (L_fp)dslect_, "N", &c__2, a, &c__2, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__6, iw, &c__1, b, &info);
chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 16;
dgeesx_("N", "N", (L_fp)dslect_, "N", &c__1, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__2, iw, &c__1, b, &info);
chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
} else if (lsamen_(&c__2, c2, "BD")) {
/* Test DGESVD */
s_copy(srnamc_1.srnamt, "DGESVD", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgesvd_("X", "N", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgesvd_("N", "X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgesvd_("O", "O", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgesvd_("N", "N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgesvd_("N", "N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dgesvd_("N", "N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__5, &info);
chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
dgesvd_("A", "N", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &
c__5, &info);
chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
dgesvd_("N", "A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__5, &info);
chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
if (infoc_1.ok) {
io___24.ciunit = infoc_1.nout;
s_wsfe(&io___24);
do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___25.ciunit = infoc_1.nout;
s_wsfe(&io___25);
e_wsfe();
}
/* Test DGESDD */
s_copy(srnamc_1.srnamt, "DGESDD", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgesdd_("X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
iw, &info);
chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgesdd_("N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
iw, &info);
chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgesdd_("N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
iw, &info);
chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgesdd_("N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5,
iw, &info);
chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dgesdd_("A", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &c__5,
iw, &info);
chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dgesdd_("A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5,
iw, &info);
chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += -2;
if (infoc_1.ok) {
io___26.ciunit = infoc_1.nout;
s_wsfe(&io___26);
do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___27.ciunit = infoc_1.nout;
s_wsfe(&io___27);
e_wsfe();
}
}
/* Print a summary line. */
if (! lsamen_(&c__2, c2, "BD")) {
if (infoc_1.ok) {
io___28.ciunit = infoc_1.nout;
s_wsfe(&io___28);
do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___29.ciunit = infoc_1.nout;
s_wsfe(&io___29);
e_wsfe();
}
}
return 0;
/* End of DERRED */
} /* derred_ */
