/* eigs_sps - computs a few eigenvalues of a sparse symmetric matrix * Inputs : * n - size * val, indx, pntrB, pntrE - represents the sparse matrix A * which - character array, can be 'SA' 'LA' 'BE' 'SM' 'LM' * nev - number of eigenvalues to be computed * d - pre-allocated array, serves as the output eigenvalues * Return Value : * (int) 0 - process exits normally * (int) != 0 - process exits with errors */ int eigs_sps(MKL_INT n, double* val, MKL_INT* indx, MKL_INT* pntrB, MKL_INT* pntrE, char* which, MKL_INT nev, double *d){ int ido = 0, ncv = int(nev*1.1+1), ldv = n, lworkl = ncv*(ncv+8), info = 0, revc = 0, ierr = 0; int iparam[11], ipntr[11], *select; unsigned long pntr0, pntr1; double tol = 0, alpha = 1.0, beta = 0.0, sigma = 0.0; double *resid, *workd, *workl, *v; char bmat[] = {'I'}, transa[] = {'N'}, matdescra[] = {'G', 'L', 'N', 'F'}, howmny[] = {'A'}; resid = new double[n]; workd = new double[3*n]; workl = new double[lworkl]; v = new double[ncv*ldv]; select = new int[ncv]; iparam[0] = 1; iparam[2] = 300; iparam[6] = 1; while(true){ dsaupd_(&ido, bmat, &n, which, &nev, &tol, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &info, 1, 2); if(ido == 1 || ido == -1){ pntr0 = (unsigned long)ipntr[0]; pntr1 = (unsigned long)ipntr[1]; mkl_dcscmv(transa, &n, &n, &alpha, matdescra, val, indx, pntrB, pntrE, (double*)pntr0, &beta, (double*)pntr1); } } dseupd_(&revc, howmny, select, d, v, &ldv, &sigma, bmat, &n, which, &ncv, &tol, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &ierr, 1, 1, 2); if(ierr != 0){ printf("Error with dseupd, info = %d\n", ierr); } delete []resid; delete []workd; delete []workl; delete []select; delete []v; return info; }
int BandArpackSolver::solve(int numModes, bool generalized, bool findSmallest) { if (generalized == false) { opserr << "BandArpackSolver::solve(int numMode, bool generalized) - only solves generalized problem\n"; return -1; } if (theSOE == 0) { opserr << "WARNING BandGenLinLapackSolver::solve(void)- "; opserr << " No LinearSOE object has been set\n"; return -1; } int n = theSOE->size; // check iPiv is large enough if (iPivSize < n) { opserr << "WARNING BandGenLinLapackSolver::solve(void)- "; opserr << " iPiv not large enough - has setSize() been called?\n"; return -1; } // set some variables int kl = theSOE->numSubD; int ku = theSOE->numSuperD; int ldA = 2*kl + ku +1; int nrhs = 1; int ldB = n; int info; double *Aptr = theSOE->A; int *iPIV = iPiv; int nev = numModes;; int ncv = getNCV(n, nev); // set up the space for ARPACK functions. // this is done each time method is called!! .. this needs to be cleaned up int ldv = n; int lworkl = ncv*ncv + 8*ncv; double *v = new double[ldv * ncv]; double *workl = new double[lworkl + 1]; double *workd = new double[3 * n + 1]; double *d = new double[nev]; double *z= new double[n * nev]; double *resid = new double[n]; int *iparam = new int[11]; int *ipntr = new int[11]; logical *select = new logical[ncv]; static char which[3]; if (findSmallest == true) { strcpy(which, "LM"); } else { strcpy(which, "SM"); } char bmat = 'G'; char howmy = 'A'; // some more variables int maxitr, mode; double tol = 0.0; info = 0; maxitr = 1000; mode = 3; iparam[0] = 1; iparam[2] = maxitr; iparam[6] = mode; bool rvec = true; int ido = 0; int ierr = 0; // Do the factorization of Matrix (A-dM) here. #ifdef _WIN32 DGBTRF(&n, &n, &kl, &ku, Aptr, &ldA, iPiv, &ierr); #else dgbtrf_(&n, &n, &kl, &ku, Aptr, &ldA, iPiv, &ierr); #endif if ( ierr != 0 ) { opserr << " BandArpackSolver::Error in dgbtrf_ " << endln; return -1; } while (1) { #ifdef _WIN32 unsigned int sizeWhich =2; unsigned int sizeBmat =1; unsigned int sizeHowmany =1; unsigned int sizeOne = 1; /* DSAUPD(&ido, &bmat, &sizeBmat, &n, which, &sizeWhich, &nev, &tol, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &info); */ DSAUPD(&ido, &bmat, &n, which, &nev, &tol, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &info); #else dsaupd_(&ido, &bmat, &n, which, &nev, &tol, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &info); #endif if (ido == -1) { myMv(n, &workd[ipntr[0]-1], &workd[ipntr[1]-1]); #ifdef _WIN32 /* DGBTRS("N", &sizeOne, &n, &kl, &ku, &nrhs, Aptr, &ldA, iPIV, &workd[ipntr[1] - 1], &ldB, &ierr); */ DGBTRS("N", &n, &kl, &ku, &nrhs, Aptr, &ldA, iPIV, &workd[ipntr[1] - 1], &ldB, &ierr); #else dgbtrs_("N", &n, &kl, &ku, &nrhs, Aptr, &ldA, iPIV, &workd[ipntr[1] - 1], &ldB, &ierr); #endif if (ierr != 0) { opserr << "BandArpackSolver::Error with dgbtrs_ 1" <<endln; exit(0); } continue; } else if (ido == 1) { // double ratio = 1.0; myCopy(n, &workd[ipntr[2]-1], &workd[ipntr[1]-1]); #ifdef _WIN32 /* DGBTRS("N", &sizeOne, &n, &kl, &ku, &nrhs, Aptr, &ldA, iPIV, &workd[ipntr[1] - 1], &ldB, &ierr); */ DGBTRS("N", &n, &kl, &ku, &nrhs, Aptr, &ldA, iPIV, &workd[ipntr[1] - 1], &ldB, &ierr); #else dgbtrs_("N", &n, &kl, &ku, &nrhs, Aptr, &ldA, iPIV, &workd[ipntr[1] - 1], &ldB, &ierr); #endif if (ierr != 0) { opserr << "BandArpackSolver::Error with dgbtrs_ 2" <<endln; exit(0); } continue; } else if (ido == 2) { myMv(n, &workd[ipntr[0]-1], &workd[ipntr[1]-1]); continue; } break; } if (info < 0) { opserr << "BandArpackSolver::Error with _saupd info = " << info << endln; switch(info) { case -1: opserr << "N must be positive.\n"; break; case -2: opserr << "NEV must be positive.\n"; break; case -3: opserr << "NCV must be greater than NEV and less than or equal to N.\n"; break; case -4: opserr << "The maximum number of Arnoldi update iterations allowed"; break; case -5: opserr << "WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'.\n"; break; case -6: opserr << "BMAT must be one of 'I' or 'G'.\n"; break; case -7: opserr << "Length of private work array WORKL is not sufficient.\n"; break; case -8: opserr << "Error return from trid. eigenvalue calculation"; opserr << "Informatinal error from LAPACK routine dsteqr.\n"; break; case -9: opserr << "Starting vector is zero.\n"; break; case -10: opserr << "IPARAM(7) must be 1,2,3,4,5.\n"; break; case -11: opserr << "IPARAM(7) = 1 and BMAT = 'G' are incompatable.\n"; break; case -12: opserr << "IPARAM(1) must be equal to 0 or 1.\n"; break; case -13: opserr << "NEV and WHICH = 'BE' are incompatable.\n"; break; case -9999: opserr << "Could not build an Arnoldi factorization."; opserr << "IPARAM(5) returns the size of the current Arnoldi\n"; opserr << "factorization. The user is advised to check that"; opserr << "enough workspace and array storage has been allocated.\n"; break; default: opserr << "unrecognised return value\n"; } // clean up the memory delete [] workl; delete [] workd; delete [] resid; delete [] iparam; delete [] v; delete [] select; delete [] ipntr; delete [] d; delete [] z; value = 0; eigenvector = 0; return info; } else { if (info == 1) { opserr << "BandArpackSolver::Maximum number of iteration reached." << endln; } else if (info == 3) { opserr << "BandArpackSolver::No Shifts could be applied during implicit,"; opserr << "Arnoldi update, try increasing NCV." << endln; } double sigma = theSOE->shift; if (iparam[4] > 0) { rvec = true; n = theSOE->size; ldv = n; #ifdef _WIN32 unsigned int sizeWhich =2; unsigned int sizeBmat =1; unsigned int sizeHowmany =1; /* DSEUPD(&rvec, &howmy, &sizeHowmany, select, d, z, &ldv, &sigma, &bmat, &sizeBmat, &n, which, &sizeWhich, &nev, &tol, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &info); */ DSEUPD(&rvec, &howmy, select, d, z, &ldv, &sigma, &bmat, &n, which, &nev, &tol, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &info); #else dseupd_(&rvec, &howmy, select, d, z, &ldv, &sigma, &bmat, &n, which, &nev, &tol, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &info); #endif if (info != 0) { opserr << "BandArpackSolver::Error with dseupd_" << info; switch(info) { case -1: opserr << " N must be positive.\n"; break; case -2: opserr << " NEV must be positive.\n"; break; case -3: opserr << " NCV must be greater than NEV and less than or equal to N.\n"; break; case -5: opserr << " WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'.\n"; break; case -6: opserr << " BMAT must be one of 'I' or 'G'.\n"; break; case -7: opserr << " Length of private work WORKL array is not sufficient.\n"; break; case -8: opserr << " Error return from trid. eigenvalue calculation"; opserr << "Information error from LAPACK routine dsteqr.\n"; break; case -9: opserr << " Starting vector is zero.\n"; break; case -10: opserr << " IPARAM(7) must be 1,2,3,4,5.\n"; break; case -11: opserr << " IPARAM(7) = 1 and BMAT = 'G' are incompatibl\n"; break; case -12: opserr << " NEV and WHICH = 'BE' are incompatible.\n"; break; case -14: opserr << " DSAUPD did not find any eigenvalues to sufficient accuracy.\n"; break; case -15: opserr << " HOWMNY must be one of 'A' or 'S' if RVEC = .true.\n"; break; case -16: opserr << " HOWMNY = 'S' not yet implemented\n"; break; default: ; } // clean up the memory delete [] workl; delete [] workd; delete [] resid; delete [] iparam; delete [] v; delete [] select; delete [] ipntr; delete [] d; delete [] z; value = 0; eigenvector = 0; return info; } } } value = d; eigenvector = z; theSOE->factored = true; // clean up the memory delete [] workl; delete [] workd; delete [] resid; delete [] iparam; delete [] v; delete [] select; delete [] ipntr; return 0; }
int main(int argc, char* argv[]) { const char* program_name = "decomp_sparse_nystrom"; bool optsOK = true; copyright(program_name); cout << " Reads the symmetric CSC format sparse matrix from" << endl; cout << " input-file, and computes the number of requested" << endl; cout << " eigenvalues/vectors of the normalized laplacian" << endl; cout << " using ARPACK and a gaussian kernel of width sigma." << endl; cout << " The general CSC format sparse matrix is projected" << endl; cout << " onto the eigenvectors of the symmetric matrix for" << endl; cerr << " out-of-sample prediction." << endl; cout << endl; cout << " Use -h or --help to see the complete list of options." << endl; cout << endl; // Option vars... double sigma_a; int nev; string ssm_filename; string gsm_filename; string evals_filename; string evecs_filename; string residuals_filename; // Declare the supported options. po::options_description cmdline_options; po::options_description program_options("Program options"); program_options.add_options() ("help,h", "show this help message and exit") ("sigma,q", po::value<double>(&sigma_a), "Input: Standard deviation of gaussian kernel (real)") ("nevals,n", po::value<int>(&nev), "Input: Number of eigenvalues/vectors (int)") ("ssm-file,s", po::value<string>(&ssm_filename)->default_value("distances.ssm"), "Input: Symmetric sparse matrix file (string:filename)") ("gsm-file,g", po::value<string>(&gsm_filename)->default_value("distances.gsm"), "Input: General sparse matrix file (string:filename)") ("evals-file,v", po::value<string>(&evals_filename)->default_value("eigenvalues.dat"), "Output: Eigenvalues file (string:filename)") ("evecs-file,e", po::value<string>(&evecs_filename)->default_value("eigenvectors.dat"), "Output: Eigenvectors file (string:filename)") ("residuals-file,r", po::value<string>(&residuals_filename)->default_value("residuals.dat"), "Output: Residuals file (string:filename)") ; cmdline_options.add(program_options); po::variables_map vm; po::store(po::parse_command_line(argc, argv, cmdline_options), vm); po::notify(vm); if (vm.count("help")) { cout << "usage: " << program_name << " [options]" << endl; cout << cmdline_options << endl; return 1; } if (!vm.count("sigma")) { cout << "ERROR: --sigma not supplied." << endl; cout << endl; optsOK = false; } if (!vm.count("nevals")) { cout << "ERROR: --nevals not supplied." << endl; cout << endl; optsOK = false; } if (!optsOK) { return -1; } cout << "Running with the following options:" << endl; cout << "sigma = " << sigma_a << endl; cout << "nevals = " << nev << endl; cout << "ssm-file = " << ssm_filename << endl; cout << "gsm-file = " << gsm_filename << endl; cout << "evals-file = " << evals_filename << endl; cout << "evecs-file = " << evecs_filename << endl; cout << "residuals-file = " << residuals_filename << endl; cout << endl; // General int n; // Dimension of the problem. int m; // Outer dimension // Main affinity matrix int nnzA; int *irowA; int *pcolA; double *A; // Pointer to an array that stores the lower // triangular elements of A. // Expanded affinity matrix int nnzB; int *irowB; int *pcolB; double *B; // Pointer to an array that stores the // sparse elements of B. // File input streams ifstream ssm; ifstream gsm; // File output streams ofstream eigenvalues; ofstream eigenvectors; ofstream residuals; // EPS double eps = 1.0; do { eps /= 2.0; } while (1.0 + (eps / 2.0) != 1.0); eps = sqrt(eps); // Open files ssm.open(ssm_filename.c_str()); gsm.open(gsm_filename.c_str()); eigenvalues.open(evals_filename.c_str()); eigenvectors.open(evecs_filename.c_str()); residuals.open(residuals_filename.c_str()); // Read symmetric CSC matrix ssm.read((char*) &n, (sizeof(int) / sizeof(char))); pcolA = new int[n+1]; ssm.read((char*) pcolA, (sizeof(int) / sizeof(char)) * (n+1)); nnzA = pcolA[n]; A = new double[nnzA]; irowA = new int[nnzA]; ssm.read((char*) irowA, (sizeof(int) / sizeof(char)) * nnzA); ssm.read((char*) A, (sizeof(double) / sizeof(char)) * nnzA); ssm.close(); // Read general CSC matrix gsm.read((char*) &m, (sizeof(int) / sizeof(char))); pcolB = new int[m+1]; gsm.read((char*) pcolB, (sizeof(int) / sizeof(char)) * (m+1)); nnzB = pcolB[m]; B = new double[nnzB]; irowB = new int[nnzB]; gsm.read((char*) irowB, (sizeof(int) / sizeof(char)) * nnzB); gsm.read((char*) B, (sizeof(double) / sizeof(char)) * nnzB); gsm.close(); // Turn distances into normalized affinities... double *d_a = new double[n]; double *d_b = new double[m]; // Make affinity matrices... for (int x = 0; x < nnzA; x++) A[x] = exp(-(A[x] * A[x]) / (2.0 * sigma_a * sigma_a)); for (int x = 0; x < nnzB; x++) B[x] = exp(-(B[x] * B[x]) / (2.0 * sigma_a * sigma_a)); // Calculate D_A for (int x = 0; x < n; x++) d_a[x] = 0.0; for (int x = 0; x < n; x++) { for (int y = pcolA[x]; y < pcolA[x+1]; y++) { d_a[x] += A[y]; d_a[irowA[y]] += A[y]; } } for (int x = 0; x < n; x++) d_a[x] = 1.0 / sqrt(d_a[x]); // Calculate D_B for (int x = 0; x < m; x++) d_b[x] = 0.0; for (int x = 0; x < m; x++) { for (int y = pcolB[x]; y < pcolB[x+1]; y++) { d_b[x] += B[y]; } } for (int x = 0; x < m; x++) d_b[x] = 1.0 / sqrt(d_b[x]); // Normalize the affinity matrix... for (int x = 0; x < n; x++) { for (int y = pcolA[x]; y < pcolA[x+1]; y++) { A[y] *= d_a[irowA[y]] * d_a[x]; } } // Normalized B matrix... for (int x = 0; x < m; x++) { for (int y = pcolB[x]; y < pcolB[x+1]; y++) { B[y] *= d_a[irowB[y]] * d_b[x]; } } delete [] d_a; delete [] d_b; // Eigen decomposition of nomalized affinity matrix... // ARPACK setup... double *Ax = new double[n]; // Array for residual calculation double residual = 0.0; double max_residual = 0.0; int ido = 0; char bmat = 'I'; char which[2]; which[0] = 'L'; which[1] = 'A'; double tol = 0.0; double *resid = new double[n]; // NOTE: Need about one order of magnitude more arnoldi vectors to // converge for the normalized Laplacian (according to residuals...) int ncv = ((10*nev+1)>n)?n:(10*nev+1); double *V = new double[(ncv*n)+1]; int ldv = n; int *iparam = new int[12]; iparam[1] = 1; iparam[3] = 100 * nev; iparam[4] = 1; iparam[7] = 1; int *ipntr = new int[15]; double *workd = new double[(3*n)+1]; int lworkl = ncv*(ncv+9); double *workl = new double[lworkl+1]; int info = 0; int rvec = 1; char HowMny = 'A'; int *lselect = new int[ncv]; double *d = new double[nev]; double *Z = &V[1]; int ldz = n; double sigma = 0.0; double *extrap_evec = new double[m]; double *norm_evec = new double[n]; while (ido != 99) { dsaupd_(&ido, &bmat, &n, which, &nev, &tol, resid, &ncv, &V[1], &ldv, &iparam[1], &ipntr[1], &workd[1], &workl[1], &lworkl, &info); if (ido == -1 || ido == 1) { // Matrix-vector multiplication sp_dsymv(n, irowA, pcolA, A, &workd[ipntr[1]], &workd[ipntr[2]]); } } dseupd_(&rvec, &HowMny, lselect, d, Z, &ldz, &sigma, &bmat, &n, which, &nev, &tol, resid, &ncv, &V[1], &ldv, &iparam[1], &ipntr[1], &workd[1], &workl[1], &lworkl, &info); cout << "Number of converged eigenvalues/vectors found: " << iparam[5] << endl; for (int x = nev-1; x >= 0; x--) { #ifdef DECOMP_WRITE_DOUBLE eigenvalues.write((char*) &d[x],(sizeof(double) / sizeof(char))); eigenvectors.write((char*) &Z[n*x],(sizeof(double) * n) / sizeof(char)); #else eigenvalues << d[x] << endl; for (int y = 0; y < n; y++) eigenvectors << Z[(n*x)+y] << " "; #endif // Extrapolate remaining points onto the vector space for (int y = 0; y < n; y++) norm_evec[y] = Z[(n*x)+y] / d[x]; sp_dgemv(m, irowB, pcolB, B, norm_evec, extrap_evec); #ifdef DECOMP_WRITE_DOUBLE eigenvectors.write((char*) extrap_evec,(sizeof(double) * m) / sizeof(char)); #else for (int y = 0; y < m; y++) eigenvectors << extrap_evec[y] << " "; eigenvectors << endl; #endif // Calculate residual... // Matrix-vector multiplication sp_dsymv(n, irowA, pcolA, A, &Z[n*x], Ax); double t = -d[x]; int i = 1; daxpy_(&n, &t, &Z[n*x], &i, Ax, &i); residual = dnrm2_(&n, Ax, &i)/fabs(d[x]); if (residual > max_residual) max_residual = residual; #ifdef DECOMP_WRITE_DOUBLE residuals.write((char*) &residual, sizeof(double) / sizeof(char)); #else residuals << residual << endl; #endif } cout << "Max residual: " << max_residual << " (eps: " << eps << ")" << endl; if (max_residual > eps) { cout << "*** Sum of residuals too high (max_r > eps)!" << endl; cout << "*** Please, check results manually..." << endl; } eigenvalues.close(); eigenvectors.close(); residuals.close(); delete [] irowA; delete [] pcolA; delete [] A; delete [] irowB; delete [] pcolB; delete [] B; // ARPACK delete [] lselect; delete [] d; delete [] resid; delete [] Ax; delete [] V; delete [] iparam; delete [] ipntr; delete [] workd; delete [] workl; delete [] norm_evec; delete [] extrap_evec; return 0; }
/** Get eigenvectors and eigenvalues. They will be stored in descending * order (largest eigenvalue first). */ int DataSet_Modes::CalcEigen(DataSet_2D const& mIn, int n_to_calc) { #ifdef NO_MATHLIB mprinterr("Error: modes: Compiled without ARPACK/LAPACK/BLAS routines.\n"); return 1; #else bool eigenvaluesOnly = false; int info = 0; if (mIn.MatrixKind() != DataSet_2D::HALF) { mprinterr("Error: DataSet_Modes: Eigenvector/value calc only for symmetric matrices.\n"); return 1; } // If number to calc is 0, assume we want eigenvalues only if (n_to_calc < 1) { if (n_to_calc == 0) eigenvaluesOnly = true; nmodes_ = (int)mIn.Ncols(); } else nmodes_ = n_to_calc; if (nmodes_ > (int)mIn.Ncols()) { mprintf("Warning: Specified # of eigenvalues to calc (%i) > matrix dimension (%i).\n", nmodes_, mIn.Ncols()); nmodes_ = mIn.Ncols(); mprintf("Warning: Only calculating %i eigenvalues.\n", nmodes_); } if (eigenvaluesOnly) mprintf("\tCalculating %i eigenvalues only.\n", nmodes_); else mprintf("\tCalculating %i eigenvectors and eigenvalues.\n", nmodes_); // ----------------------------------------------------------------- if (nmodes_ == (int)mIn.Ncols()) { // Calculate all eigenvalues (and optionally eigenvectors). char jobz = 'V'; // Default: Calc both eigenvectors and eigenvalues vecsize_ = mIn.Ncols(); // Check if only calculating eigenvalues if (eigenvaluesOnly) { jobz = 'N'; vecsize_ = 1; } // Set up space to hold eigenvectors if (evectors_ != 0) delete[] evectors_; if (!eigenvaluesOnly) evectors_ = new double[ nmodes_ * vecsize_ ]; else evectors_ = 0; // Set up space to hold eigenvalues if (evalues_ != 0) delete[] evalues_; evalues_ = new double[ nmodes_ ]; // Create copy of matrix since call to dspev destroys it double* mat = mIn.MatrixArray(); // Lower triangle; not upper since fortran array layout is inverted w.r.t. C/C++ char uplo = 'L'; // Allocate temporary workspace double* work = new double[ 3 * nmodes_ ]; // NOTE: The call to dspev is supposed to store eigenvectors in columns. // However as mentioned above fortran array layout is inverted // w.r.t. C/C++ so eigenvectors end up in rows. // NOTE: Eigenvalues/vectors are returned in ascending order. dspev_(jobz, uplo, nmodes_, mat, evalues_, evectors_, vecsize_, work, info); // If no eigenvectors calcd set vecsize to 0 if (evectors_==0) vecsize_ = 0; delete[] work; delete[] mat; if (info != 0) { if (info < 0) { mprinterr("Internal Error: from dspev: Argument %i had illegal value.\n", -info); mprinterr("Args: %c %c %i matrix %x %x %i work %i\n", jobz, uplo, nmodes_, evalues_, evectors_, vecsize_, info); } else { // info > 0 mprinterr("Internal Error: from dspev: The algorithm failed to converge.\n"); mprinterr("%i off-diagonal elements of an intermediate tridiagonal form\n", info); mprinterr("did not converge to zero.\n"); } return 1; } // ----------------------------------------------------------------- } else { // Calculate up to n-1 eigenvalues/vectors using the Implicitly Restarted // Arnoldi iteration. // FIXME: Eigenvectors obtained with this method appear to have signs // flipped compared to full method - is dot product wrong? int nelem = mIn.Ncols(); // Dimension of input matrix (N) // Allocate memory to store eigenvectors vecsize_ = mIn.Ncols(); int ncv; // # of columns of the matrix V (evectors_), <= N (mIn.Ncols()) if (evectors_!=0) delete[] evectors_; if (nmodes_*2 <= nelem) ncv = nmodes_*2; else ncv = nelem; evectors_ = new double[ ncv * nelem ]; // Temporary storage for eigenvectors to avoid memory overlap in dseupd double* eigenvectors = new double[ ncv * nelem ]; // Allocate memory to store eigenvalues if ( evalues_ != 0) delete[] evalues_; evalues_ = new double[ nelem ] ; // NOTE: Should this be nmodes? // Allocate workspace double* workd = new double[ 3 * nelem ]; int lworkl = ncv * (ncv+8); // NOTE: should this be ncv^2 * (ncv+8) double* workl = new double[ lworkl ]; double* resid = new double[ nelem ]; // Set parameters for dsaupd (Arnolid) int ido = 0; // Reverse comm. flag; 0 = first call // The iparam array is used to set parameters for the calc. int iparam[11]; std::fill( iparam, iparam + 11, 0 ); iparam[0] = 1; // Method for selecting implicit shifts; 1 = exact iparam[2] = 300; // Max # of iterations allowed iparam[3] = 1; // blocksize to be used in the recurrence (code works with only 1). iparam[6] = 1; // Type of eigenproblem being solved; 1: A*x = lambda*x double tol = 0; // Stopping criterion (tolerance); 0 = arpack default char bmat = 'I'; // Type of matrix B that defines semi-inner product; I = identity char which[2]; // Which of the Ritz values of OP to compute; which[0] = 'L'; // 'LA' = compute the NEV largest eigenvalues which[1] = 'A'; // The ipntr array will hold starting locations in workd and workl arrays // for matrices/vectors used by the Lanczos iteration. int ipntr[11]; std::fill( ipntr, ipntr + 11, 0 ); // Create copy of matrix since it will be modified double* mat = mIn.MatrixArray(); // LOOP bool loop = false; do { if (loop) { // Dot products double* target = workd + (ipntr[1] - 1); // -1 since fortran indexing starts at 1 double* vec = workd + (ipntr[0] - 1); std::fill( target, target + nelem, 0 ); for(int i = 0; i < nelem; i++) { for(int j = i; j < nelem; j++) { int ind = nelem * i + j - (i * (i + 1)) / 2; target[i] += mat[ind] * vec[j]; if(i != j) target[j] += mat[ind] * vec[i]; } } } dsaupd_(ido, bmat, nelem, which, nmodes_, tol, resid, ncv, eigenvectors, nelem, iparam, ipntr, workd, workl, lworkl, info); loop = (ido == -1 || ido == 1); } while ( loop ); // END LOOP if (info != 0) { mprinterr("Error: DataSet_Modes: dsaupd returned %i\n",info); } else { int rvec = 1; char howmny = 'A'; double sigma = 0.0; int* select = new int[ ncv ]; dseupd_(rvec, howmny, select, evalues_, evectors_, nelem, sigma, bmat, nelem, which, nmodes_, tol, resid, ncv, eigenvectors, nelem, iparam, ipntr, workd, workl, lworkl, info); delete[] select; } delete[] mat; delete[] workl; delete[] workd; delete[] resid; delete[] eigenvectors; if (info != 0) { mprinterr("Error: DataSet_Modes: dseupd returned %i\n",info); return 1; } } // Eigenvalues and eigenvectors are in ascending order. Resort so that // they are in descending order (i.e. largest eigenvalue first). int pivot = nmodes_ / 2; int nmode = nmodes_ - 1; double* vtmp = 0; if (evectors_ != 0) vtmp = new double[ vecsize_ ]; for (int mode = 0; mode < pivot; ++mode) { // Swap eigenvalue double eval = evalues_[mode]; evalues_[mode] = evalues_[nmode]; evalues_[nmode] = eval; // Swap eigenvector if (vtmp != 0) { double* Vec0 = evectors_ + (mode * vecsize_); double* Vec1 = evectors_ + (nmode * vecsize_); std::copy( Vec0, Vec0 + vecsize_, vtmp ); std::copy( Vec1, Vec1 + vecsize_, Vec0 ); std::copy( vtmp, vtmp + vecsize_, Vec1 ); } --nmode; } if (vtmp != 0) delete[] vtmp; return 0; #endif }
int ArpackSolver::solve(int numModes, bool generalized) { if (generalized == false) { opserr << "ArpackSolver::solve() - at moment only solves generalized problem\n"; return -1; } theSOE = theArpackSOE->theSOE; if (theSOE == 0) { opserr << "ArpackSolver::setSize() - no LinearSOE set\n"; return -1; } // set up the space for ARPACK functions. // this is done each time method is called!! .. this needs to be cleaned up int n = size; int nev = numModes; int ncv = getNCV(n, nev); int ldv = n; int lworkl = ncv*ncv + 8*ncv; int processID = theArpackSOE->processID; // set up the space for ARPACK functions. // this is done each time method is called!! .. this needs to be cleaned up if (numModes > numModesMax) { if (v != 0) delete [] v; if (workl != 0) delete [] workl; if (workd != 0) delete [] workd; if (eigenvalues != 0) delete [] eigenvalues; if (eigenvectors != 0) delete [] eigenvectors; if (resid != 0) delete [] resid; if (select != 0) delete [] select; v = new double[ldv * ncv]; workl = new double[lworkl + 1]; workd = new double[3 * n + 1]; eigenvalues = new double[nev]; eigenvectors = new double[n * nev]; resid = new double[n]; select = new logical[ncv]; for (int i=0; i<lworkl+1; i++) workl[i] = 0; for (int i=0; i<3*n+1; i++) workd[i] = 0; for (int i=0; i<ldv*ncv; i++) v[i] = 0; numModesMax = numModes; } static char which[3]; strcpy(which, "LM"); char bmat = 'G'; char howmy = 'A'; // some more variables double tol = 0.0; int info = 0; int maxitr = 1000; int mode = 3; iparam[0] = 1; iparam[2] = maxitr; iparam[6] = mode; bool rvec = true; int ido = 0; int ierr = 0; while (1) { #ifdef _WIN32 unsigned int sizeWhich =2; unsigned int sizeBmat =1; unsigned int sizeHowmany =1; unsigned int sizeOne = 1; DSAUPD(&ido, &bmat, &n, which, &nev, &tol, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &info); #else dsaupd_(&ido, &bmat, &n, which, &nev, &tol, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &info); #endif if (ido == -1) { myMv(n, &workd[ipntr[0]-1], &workd[ipntr[1]-1]); theVector.setData(&workd[ipntr[1] - 1], size); theSOE->setB(theVector); ierr = theSOE->solve(); const Vector &X = theSOE->getX(); theVector = X; continue; } else if (ido == 1) { // double ratio = 1.0; myCopy(n, &workd[ipntr[2]-1], &workd[ipntr[1]-1]); theVector.setData(&workd[ipntr[1] - 1], size); if (processID > 0) theSOE->zeroB(); else theSOE->setB(theVector); theSOE->solve(); const Vector &X = theSOE->getX(); theVector = X; // theVector.setData(&workd[ipntr[1] - 1], size); continue; } else if (ido == 2) { myMv(n, &workd[ipntr[0]-1], &workd[ipntr[1]-1]); continue; } break; } if (info < 0) { opserr << "ArpackSolver::Error with _saupd info = " << info << endln; switch(info) { case -1: opserr << "N must be positive.\n"; break; case -2: opserr << "NEV must be positive.\n"; break; case -3: opserr << "NCV must be greater than NEV and less than or equal to N.\n"; break; case -4: opserr << "The maximum number of Arnoldi update iterations allowed"; break; case -5: opserr << "WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'.\n"; break; case -6: opserr << "BMAT must be one of 'I' or 'G'.\n"; break; case -7: opserr << "Length of private work array WORKL is not sufficient.\n"; break; case -8: opserr << "Error return from trid. eigenvalue calculation"; opserr << "Informatinal error from LAPACK routine dsteqr.\n"; break; case -9: opserr << "Starting vector is zero.\n"; break; case -10: opserr << "IPARAM(7) must be 1,2,3,4,5.\n"; break; case -11: opserr << "IPARAM(7) = 1 and BMAT = 'G' are incompatable.\n"; break; case -12: opserr << "IPARAM(1) must be equal to 0 or 1.\n"; break; case -13: opserr << "NEV and WHICH = 'BE' are incompatable.\n"; break; case -9999: opserr << "Could not build an Arnoldi factorization."; opserr << "IPARAM(5) the size of the current Arnoldi factorization: is "; opserr << iparam[4]; opserr << "factorization. The user is advised to check that"; opserr << "enough workspace and array storage has been allocated.\n"; break; default: opserr << "unrecognised return value\n"; } eigenvalues = 0; eigenvectors = 0; return info; } else { if (info == 1) { opserr << "ArpackSolver::Maximum number of iteration reached." << endln; } else if (info == 3) { opserr << "ArpackSolver::No Shifts could be applied during implicit,"; opserr << "Arnoldi update, try increasing NCV." << endln; } double sigma = shift; if (iparam[4] > 0) { rvec = true; n = size; ldv = n; #ifdef _WIN32 unsigned int sizeWhich =2; unsigned int sizeBmat =1; unsigned int sizeHowmany =1; DSEUPD(&rvec, &howmy, select, eigenvalues, eigenvectors, &ldv, &sigma, &bmat, &n, which, &nev, &tol, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &info); #else dseupd_(&rvec, &howmy, select, eigenvalues, eigenvectors, &ldv, &sigma, &bmat, &n, which, &nev, &tol, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &info); #endif if (info != 0) { opserr << "ArpackSolver::Error with dseupd_" << info; switch(info) { case -1: opserr << " N must be positive.\n"; break; case -2: opserr << " NEV must be positive.\n"; break; case -3: opserr << " NCV must be greater than NEV and less than or equal to N.\n"; break; case -5: opserr << " WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'.\n"; break; case -6: opserr << " BMAT must be one of 'I' or 'G'.\n"; break; case -7: opserr << " Length of private work WORKL array is not sufficient.\n"; break; case -8: opserr << " Error return from trid. eigenvalue calculation"; opserr << "Information error from LAPACK routine dsteqr.\n"; break; case -9: opserr << " Starting vector is zero.\n"; break; case -10: opserr << " IPARAM(7) must be 1,2,3,4,5.\n"; break; case -11: opserr << " IPARAM(7) = 1 and BMAT = 'G' are incompatibl\n"; break; case -12: opserr << " NEV and WHICH = 'BE' are incompatible.\n"; break; case -14: opserr << " DSAUPD did not find any eigenvalues to sufficient accuracy.\n"; break; case -15: opserr << " HOWMNY must be one of 'A' or 'S' if RVEC = .true.\n"; break; case -16: opserr << " HOWMNY = 'S' not yet implemented\n"; break; default: ; } return info; } } } numMode = numModes; // clean up the memory return 0; }
/* obtain min and max of real part eigenvalues by dsaupd_() * INPUT * n : dimension of the matrix * atimes (n, x, b, user_data) : routine to calc A.x and return b[] * user_data : pointer to be passed to solver and atimes routines * eps : required precision * OUTPUT * l[2] : l[0] = min * l[1] = max */ void dsaupd_wrap_min_max (int n, double *l, void (*atimes) (int, const double *, double *, void *), void *user_data, double eps) { char bmat[2] = "I"; // standard eigenvalue problem A*x = lambda*x char SA[3] = "SA"; // compute the NEV smallest (algebraic) eigenvalues. char LA[3] = "LA"; // compute the NEV largest (algebraic) eigenvalues. int nev = 1; double *resid = (double *)malloc (sizeof (double) * n); CHECK_MALLOC (resid, "dsaupd_wrap_min_max"); int ncv; /* //ncv = 2 * nev + 1; ncv = 2 * nev * 14; if (ncv < 4) ncv = 4; if (ncv > n) ncv = n; */ ncv = n; //fprintf (stderr, "# n = %d, nev = %d, ncv = %d\n", n, nev, ncv); int ldv = n; double *v = (double *)malloc (sizeof (double) * ldv*ncv); CHECK_MALLOC (v, "dsaupd_wrap_min_max"); int iparam[11]; int ishift = 1; // exact shifts int maxitr = 3 * n; // max iterations of Arnoldi steps int mode = 1; // type of eigenproblem iparam[0] = ishift; // IPARAM(1) = ISHIFT iparam[2] = maxitr; // IPARAM(3) = MXITER iparam[6] = mode; // IPARAM(7) = MODE int ipntr[11]; int lworkl = ncv*(ncv+8); double *workd = (double *)malloc (sizeof (double) * 3 * n); double *workl = (double *)malloc (sizeof (double) * lworkl); CHECK_MALLOC (workd, "dsaupd_wrap_min_max"); CHECK_MALLOC (workl, "dsaupd_wrap_min_max"); // for post-process int rvec = 0; // false? (no eigenvectors) char howmny[2] = "A"; // Compute NEV Ritz vectors; int *select = (int *)malloc (sizeof (int) * ncv); double *d = (double *)malloc (sizeof (double) * nev); double *z = (double *)malloc (sizeof (double) * n * nev); CHECK_MALLOC (select, "dsaupd_wrap_min_max"); CHECK_MALLOC (d, "dsaupd_wrap_min_max"); CHECK_MALLOC (z, "dsaupd_wrap_min_max"); int ldz = n; double sigma; int ierr; // The Smallest Eigenvalue int ido = 0; // restart int info = 0; // a randomly initial residual vector is used. dsaupd_(&ido, bmat, &n, SA, &nev, &eps, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &info); while (ido == -1 || ido == 1) { atimes (n, workd + ipntr[0] - 1, // workd(ipntr(1)) workd + ipntr[1] - 1, // workd(ipntr(2)) user_data); dsaupd_(&ido, bmat, &n, SA, &nev, &eps, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &info); } if (info < 0) { fprintf (stdout, "Error with dsaupd;\n"); dsaupd_info (stderr, info); } else { dseupd_(&rvec, howmny, select, d, z, &ldz, &sigma, bmat, &n, SA, &nev, &eps, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &ierr); if (ierr != 0) { fprintf (stdout, "Error with dseupd;\n"); dseupd_info (stdout, ierr); } else if (info != 0) { dsaupd_info (stderr, info); } /* int nconv = iparam[4]; fprintf (stdout, " _NDRV1 \n"); fprintf (stdout, " ====== \n\n"); fprintf (stdout, " Size of the matrix is %d\n", n); fprintf (stdout, " The number of Ritz values requested is %d\n", nev); fprintf (stdout, " The number of Arnoldi vectors generated" " (NCV) is %d\n", ncv); fprintf (stdout, " What portion of the spectrum: %s\n", SA); fprintf (stdout, " The number of converged Ritz values is %d\n", nconv); fprintf (stdout, " The number of Implicit Arnoldi update" " iterations taken is %d\n", iparam[2]); fprintf (stdout, " The number of OP*x is %d\n", iparam[8]); fprintf (stdout, " The convergence criterion is %e\n", eps); fprintf (stdout, "d [0] = %e + i %e\n", dr[0], di[0]); */ l[0] = d[0]; } // The Largest Eigenvalue ido = 0; info = 0; // a randomly initial residual vector is used. //info = 1; /* RESID contains the initial residual vector, * possibly from a previous run. */ dsaupd_(&ido, bmat, &n, LA, &nev, &eps, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &info); while (ido == -1 || ido == 1) { atimes (n, workd + ipntr[0] - 1, // workd(ipntr(1)) workd + ipntr[1] - 1, // workd(ipntr(2)) user_data); dsaupd_(&ido, bmat, &n, LA, &nev, &eps, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &info); } if (info < 0) { fprintf (stdout, "Error with dsaupd;\n"); dsaupd_info (stderr, info); } else { dseupd_(&rvec, howmny, select, d, z, &ldz, &sigma, bmat, &n, LA, &nev, &eps, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &ierr); if (ierr != 0) { fprintf (stdout, "Error with dseupd;\n"); dseupd_info (stdout, ierr); } else if (info != 0) { dsaupd_info (stderr, info); } /* int nconv = iparam[4]; fprintf (stdout, "nconv = %d\n", nconv); fprintf (stdout, " _NDRV1 \n"); fprintf (stdout, " ====== \n\n"); fprintf (stdout, " Size of the matrix is %d\n", n); fprintf (stdout, " The number of Ritz values requested is %d\n", nev); fprintf (stdout, " The number of Arnoldi vectors generated" " (NCV) is %d\n", ncv); fprintf (stdout, " What portion of the spectrum: %s\n", LA); fprintf (stdout, " The number of converged Ritz values is %d\n", nconv); fprintf (stdout, " The number of Implicit Arnoldi update" " iterations taken is %d\n", iparam[2]); fprintf (stdout, " The number of OP*x is %d\n", iparam[8]); fprintf (stdout, " The convergence criterion is %e\n", eps); fprintf (stdout, "d [0] = %e + i %e\n", dr[0], di[0]); */ l[1] = d[0]; } free (resid); free (workd); free (workl); free (v); free (select); free (d); free (z); }
void arpack_dsaupd(double* matrix, int n, int nev, const char* which, int mode, bool pos, double shift, double* eigenvalues, double* eigenvectors, int& status) { // check if nev is greater than n if (nev>n) SG_SERROR("Number of required eigenpairs is greater than order of the matrix"); // check specified mode if (mode!=1 && mode!=3) SG_SERROR("Unknown mode specified"); // init ARPACK's reverse communication parameter // (should be zero initially) int ido = 0; // specify that non-general eigenproblem will be solved // (Ax=lGx, where G=I) char bmat[2] = "I"; // init tolerance (zero means machine precision) double tol = 0.0; // allocate array to hold residuals double* resid = new double[n]; // set number of Lanczos basis vectors to be used // (with max(4*nev,n) sufficient for most tasks) int ncv = nev*4>n ? n : nev*4; // allocate array 'v' for dsaupd routine usage int ldv = n; double* v = new double[ldv*ncv]; // init array for i/o params for routine int* iparam = new int[11]; // specify method for selecting implicit shifts (1 - exact shifts) iparam[0] = 1; // specify max number of iterations iparam[2] = 2*2*n; // set the computation mode (1 for regular or 3 for shift-inverse) iparam[6] = mode; // init array indicating locations of vectors for routine callback int* ipntr = new int[11]; // allocate workaround arrays double* workd = new double[3*n]; int lworkl = ncv*(ncv+8); double* workl = new double[lworkl]; // init info holding status (should be zero at first call) int info = 0; // which eigenpairs to find char* which_ = strdup(which); // All char* all_ = strdup("A"); // shift-invert mode if (mode==3) { for (int i=0; i<n; i++) matrix[i*n+i] -= shift; if (pos) { clapack_dpotrf(CblasColMajor,CblasUpper,n,matrix,n); clapack_dpotri(CblasColMajor,CblasUpper,n,matrix,n); } else { int* ipiv = new int[n]; clapack_dgetrf(CblasColMajor,n,n,matrix,n,ipiv); clapack_dgetri(CblasColMajor,n,matrix,n,ipiv); delete[] ipiv; } } // main computation loop do { dsaupd_(&ido, bmat, &n, which_, &nev, &tol, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &info); if ((ido==1)||(ido==-1)) { cblas_dsymv(CblasColMajor,CblasUpper, n,1.0,matrix,n, (workd+ipntr[0]-1),1, 0.0,(workd+ipntr[1]-1),1); } } while ((ido==1)||(ido==-1)); // check if DSAUPD failed if (info<0) { if ((info<=-1)&&(info>=-6)) SG_SWARNING("DSAUPD failed. Wrong parameter passed."); else if (info==-7) SG_SWARNING("DSAUPD failed. Workaround array size is not sufficient."); else SG_SWARNING("DSAUPD failed. Error code: %d.", info); status = -1; } else { if (info==1) SG_SWARNING("Maximum number of iterations reached.\n"); // allocate select for dseupd int* select = new int[ncv]; // allocate d to hold eigenvalues double* d = new double[2*ncv]; // sigma for dseupd double sigma = shift; // init ierr indicating dseupd possible errors int ierr = 0; // specify that eigenvectors to be computed too int rvec = 1; dseupd_(&rvec, all_, select, d, v, &ldv, &sigma, bmat, &n, which_, &nev, &tol, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, &ierr); if (ierr!=0) { SG_SWARNING("DSEUPD failed with status=%d", ierr); status = -1; } else { for (int i=0; i<nev; i++) { eigenvalues[i] = d[i]; for (int j=0; j<n; j++) eigenvectors[j*nev+i] = v[i*n+j]; } } // cleanup delete[] select; delete[] d; } // cleanup delete[] all_; delete[] which_; delete[] resid; delete[] v; delete[] iparam; delete[] ipntr; delete[] workd; delete[] workl; };