static void Main(string[] args) { try { FortranLib.ProgressUpdateAction updateProgress = delegate(ref int p) { Console.WriteLine("Progress: " + p + "%"); }; FortranLib.DoWork(ref updateProgress); } catch (Exception ex) { Console.WriteLine(ex); } }
/// <summary> /// Purpose /// ======= /// /// DLASD8 finds the square roots of the roots of the secular equation, /// as defined by the values in DSIGMA and Z. It makes the appropriate /// calls to DLASD4, and stores, for each element in D, the distance /// to its two nearest poles (elements in DSIGMA). It also updates /// the arrays VF and VL, the first and last components of all the /// right singular vectors of the original bidiagonal matrix. /// /// DLASD8 is called from DLASD6. /// ///</summary> /// <param name="ICOMPQ"> /// (input) INTEGER /// Specifies whether singular vectors are to be computed in /// factored form in the calling routine: /// = 0: Compute singular values only. /// = 1: Compute singular vectors in factored form as well. ///</param> /// <param name="K"> /// (input) INTEGER /// The number of terms in the rational function to be solved /// by DLASD4. K .GE. 1. ///</param> /// <param name="D"> /// (output) DOUBLE PRECISION array, dimension ( K ) /// On output, D contains the updated singular values. ///</param> /// <param name="Z"> /// (input) DOUBLE PRECISION array, dimension ( K ) /// The first K elements of this array contain the components /// of the deflation-adjusted updating row vector. ///</param> /// <param name="VF"> /// (input/output) DOUBLE PRECISION array, dimension ( K ) /// On entry, VF contains information passed through DBEDE8. /// On exit, VF contains the first K components of the first /// components of all right singular vectors of the bidiagonal /// matrix. ///</param> /// <param name="VL"> /// (input/output) DOUBLE PRECISION array, dimension ( K ) /// On entry, VL contains information passed through DBEDE8. /// On exit, VL contains the first K components of the last /// components of all right singular vectors of the bidiagonal /// matrix. ///</param> /// <param name="DIFL"> /// (output) DOUBLE PRECISION array, dimension ( K ) /// On exit, DIFL(I) = D(I) - DSIGMA(I). ///</param> /// <param name="DIFR"> /// (output) DOUBLE PRECISION array, /// dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and /// dimension ( K ) if ICOMPQ = 0. /// On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not /// defined and will not be referenced. /// /// If ICOMPQ = 1, DIFR(1:K,2) is an array containing the /// normalizing factors for the right singular vector matrix. ///</param> /// <param name="LDDIFR"> /// (input) INTEGER /// The leading dimension of DIFR, must be at least K. ///</param> /// <param name="DSIGMA"> /// (input) DOUBLE PRECISION array, dimension ( K ) /// The first K elements of this array contain the old roots /// of the deflated updating problem. These are the poles /// of the secular equation. ///</param> /// <param name="WORK"> /// (workspace) DOUBLE PRECISION array, dimension at least 3 * K ///</param> /// <param name="INFO"> /// (output) INTEGER /// = 0: successful exit. /// .LT. 0: if INFO = -i, the i-th argument had an illegal value. /// .GT. 0: if INFO = 1, an singular value did not converge ///</param> public void Run(int ICOMPQ, int K, ref double[] D, int offset_d, ref double[] Z, int offset_z, ref double[] VF, int offset_vf, ref double[] VL, int offset_vl , ref double[] DIFL, int offset_difl, ref double[] DIFR, int offset_difr, int LDDIFR, ref double[] DSIGMA, int offset_dsigma, ref double[] WORK, int offset_work, ref int INFO) { #region Variables int I = 0; int IWK1 = 0; int IWK2 = 0; int IWK2I = 0; int IWK3 = 0; int IWK3I = 0; int J = 0; double DIFLJ = 0; double DIFRJ = 0; double DJ = 0; double DSIGJ = 0; double DSIGJP = 0; double RHO = 0; double TEMP = 0; #endregion #region Implicit Variables int DIFR_1 = 0; #endregion #region Array Index Correction int o_d = -1 + offset_d; int o_z = -1 + offset_z; int o_vf = -1 + offset_vf; int o_vl = -1 + offset_vl; int o_difl = -1 + offset_difl; int o_difr = -1 - LDDIFR + offset_difr; int o_dsigma = -1 + offset_dsigma; int o_work = -1 + offset_work; #endregion #region Prolog // * // * -- LAPACK auxiliary routine (version 3.1) -- // * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. // * November 2006 // * // * .. Scalar Arguments .. // * .. // * .. Array Arguments .. // * .. // * // * Purpose // * ======= // * // * DLASD8 finds the square roots of the roots of the secular equation, // * as defined by the values in DSIGMA and Z. It makes the appropriate // * calls to DLASD4, and stores, for each element in D, the distance // * to its two nearest poles (elements in DSIGMA). It also updates // * the arrays VF and VL, the first and last components of all the // * right singular vectors of the original bidiagonal matrix. // * // * DLASD8 is called from DLASD6. // * // * Arguments // * ========= // * // * ICOMPQ (input) INTEGER // * Specifies whether singular vectors are to be computed in // * factored form in the calling routine: // * = 0: Compute singular values only. // * = 1: Compute singular vectors in factored form as well. // * // * K (input) INTEGER // * The number of terms in the rational function to be solved // * by DLASD4. K >= 1. // * // * D (output) DOUBLE PRECISION array, dimension ( K ) // * On output, D contains the updated singular values. // * // * Z (input) DOUBLE PRECISION array, dimension ( K ) // * The first K elements of this array contain the components // * of the deflation-adjusted updating row vector. // * // * VF (input/output) DOUBLE PRECISION array, dimension ( K ) // * On entry, VF contains information passed through DBEDE8. // * On exit, VF contains the first K components of the first // * components of all right singular vectors of the bidiagonal // * matrix. // * // * VL (input/output) DOUBLE PRECISION array, dimension ( K ) // * On entry, VL contains information passed through DBEDE8. // * On exit, VL contains the first K components of the last // * components of all right singular vectors of the bidiagonal // * matrix. // * // * DIFL (output) DOUBLE PRECISION array, dimension ( K ) // * On exit, DIFL(I) = D(I) - DSIGMA(I). // * // * DIFR (output) DOUBLE PRECISION array, // * dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and // * dimension ( K ) if ICOMPQ = 0. // * On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not // * defined and will not be referenced. // * // * If ICOMPQ = 1, DIFR(1:K,2) is an array containing the // * normalizing factors for the right singular vector matrix. // * // * LDDIFR (input) INTEGER // * The leading dimension of DIFR, must be at least K. // * // * DSIGMA (input) DOUBLE PRECISION array, dimension ( K ) // * The first K elements of this array contain the old roots // * of the deflated updating problem. These are the poles // * of the secular equation. // * // * WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K // * // * INFO (output) INTEGER // * = 0: successful exit. // * < 0: if INFO = -i, the i-th argument had an illegal value. // * > 0: if INFO = 1, an singular value did not converge // * // * Further Details // * =============== // * // * Based on contributions by // * Ming Gu and Huan Ren, Computer Science Division, University of // * California at Berkeley, USA // * // * ===================================================================== // * // * .. Parameters .. // * .. // * .. Local Scalars .. // * .. // * .. External Subroutines .. // * .. // * .. External Functions .. // * .. // * .. Intrinsic Functions .. // INTRINSIC ABS, SIGN, SQRT; // * .. // * .. Executable Statements .. // * // * Test the input parameters. // * #endregion #region Body INFO = 0; // * if ((ICOMPQ < 0) || (ICOMPQ > 1)) { INFO = -1; } else { if (K < 1) { INFO = -2; } else { if (LDDIFR < K) { INFO = -9; } } } if (INFO != 0) { this._xerbla.Run("DLASD8", -INFO); return; } // * // * Quick return if possible // * if (K == 1) { D[1 + o_d] = Math.Abs(Z[1 + o_z]); DIFL[1 + o_difl] = D[1 + o_d]; if (ICOMPQ == 1) { DIFL[2 + o_difl] = ONE; DIFR[1 + 2 * LDDIFR + o_difr] = ONE; } return; } // * // * Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can // * be computed with high relative accuracy (barring over/underflow). // * This is a problem on machines without a guard digit in // * add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). // * The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), // * which on any of these machines zeros out the bottommost // * bit of DSIGMA(I) if it is 1; this makes the subsequent // * subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation // * occurs. On binary machines with a guard digit (almost all // * machines) it does not change DSIGMA(I) at all. On hexadecimal // * and decimal machines with a guard digit, it slightly // * changes the bottommost bits of DSIGMA(I). It does not account // * for hexadecimal or decimal machines without guard digits // * (we know of none). We use a subroutine call to compute // * 2*DSIGMA(I) to prevent optimizing compilers from eliminating // * this code. // * for (I = 1; I <= K; I++) { DSIGMA[I + o_dsigma] = this._dlamc3.Run(DSIGMA[I + o_dsigma], DSIGMA[I + o_dsigma]) - DSIGMA[I + o_dsigma]; } // * // * Book keeping. // * IWK1 = 1; IWK2 = IWK1 + K; IWK3 = IWK2 + K; IWK2I = IWK2 - 1; IWK3I = IWK3 - 1; // * // * Normalize Z. // * RHO = this._dnrm2.Run(K, Z, offset_z, 1); this._dlascl.Run("G", 0, 0, RHO, ONE, K , 1, ref Z, offset_z, K, ref INFO); RHO *= RHO; // * // * Initialize WORK(IWK3). // * this._dlaset.Run("A", K, 1, ONE, ONE, ref WORK, IWK3 + o_work , K); // * // * Compute the updated singular values, the arrays DIFL, DIFR, // * and the updated Z. // * DIFR_1 = 1 * LDDIFR + o_difr; for (J = 1; J <= K; J++) { this._dlasd4.Run(K, J, DSIGMA, offset_dsigma, Z, offset_z, ref WORK, IWK1 + o_work, RHO , ref D[J + o_d], ref WORK, IWK2 + o_work, ref INFO); // * // * If the root finder fails, the computation is terminated. // * if (INFO != 0) { return; } WORK[IWK3I + J + o_work] = WORK[IWK3I + J + o_work] * WORK[J + o_work] * WORK[IWK2I + J + o_work]; DIFL[J + o_difl] = -WORK[J + o_work]; DIFR[J + DIFR_1] = -WORK[J + 1 + o_work]; for (I = 1; I <= J - 1; I++) { WORK[IWK3I + I + o_work] = WORK[IWK3I + I + o_work] * WORK[I + o_work] * WORK[IWK2I + I + o_work] / (DSIGMA[I + o_dsigma] - DSIGMA[J + o_dsigma]) / (DSIGMA[I + o_dsigma] + DSIGMA[J + o_dsigma]); } for (I = J + 1; I <= K; I++) { WORK[IWK3I + I + o_work] = WORK[IWK3I + I + o_work] * WORK[I + o_work] * WORK[IWK2I + I + o_work] / (DSIGMA[I + o_dsigma] - DSIGMA[J + o_dsigma]) / (DSIGMA[I + o_dsigma] + DSIGMA[J + o_dsigma]); } } // * // * Compute updated Z. // * for (I = 1; I <= K; I++) { Z[I + o_z] = FortranLib.Sign(Math.Sqrt(Math.Abs(WORK[IWK3I + I + o_work])), Z[I + o_z]); } // * // * Update VF and VL. // * for (J = 1; J <= K; J++) { DIFLJ = DIFL[J + o_difl]; DJ = D[J + o_d]; DSIGJ = -DSIGMA[J + o_dsigma]; if (J < K) { DIFRJ = -DIFR[J + 1 * LDDIFR + o_difr]; DSIGJP = -DSIGMA[J + 1 + o_dsigma]; } WORK[J + o_work] = -Z[J + o_z] / DIFLJ / (DSIGMA[J + o_dsigma] + DJ); for (I = 1; I <= J - 1; I++) { WORK[I + o_work] = Z[I + o_z] / (this._dlamc3.Run(DSIGMA[I + o_dsigma], DSIGJ) - DIFLJ) / (DSIGMA[I + o_dsigma] + DJ); } for (I = J + 1; I <= K; I++) { WORK[I + o_work] = Z[I + o_z] / (this._dlamc3.Run(DSIGMA[I + o_dsigma], DSIGJP) + DIFRJ) / (DSIGMA[I + o_dsigma] + DJ); } TEMP = this._dnrm2.Run(K, WORK, offset_work, 1); WORK[IWK2I + J + o_work] = this._ddot.Run(K, WORK, offset_work, 1, VF, offset_vf, 1) / TEMP; WORK[IWK3I + J + o_work] = this._ddot.Run(K, WORK, offset_work, 1, VL, offset_vl, 1) / TEMP; if (ICOMPQ == 1) { DIFR[J + 2 * LDDIFR + o_difr] = TEMP; } } // * this._dcopy.Run(K, WORK, IWK2 + o_work, 1, ref VF, offset_vf, 1); this._dcopy.Run(K, WORK, IWK3 + o_work, 1, ref VL, offset_vl, 1); // * return; // * // * End of DLASD8 // * #endregion }
public void Run(int N, double[] X, int offset_x, double F, double[] G, int offset_g, int IPRINT, int ITFILE , int ITER, int NFGV, int NACT, double SBGNRM, int NINT, ref BFGSWord WORD , int IWORD, int IBACK, double STP, double XSTEP) { #region Variables int I = 0; int IMOD = 0; #endregion #region Array Index Correction int o_x = -1 + offset_x; int o_g = -1 + offset_g; #endregion #region Prolog // c ************ // c // c Subroutine prn2lb // c // c This subroutine prints out new information after a successful // c line search. // c // c // c * * * // c // c NEOS, November 1994. (Latest revision June 1996.) // c Optimization Technology Center. // c Argonne National Laboratory and Northwestern University. // c Written by // c Ciyou Zhu // c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. // c // c // c ************ // c 'word' records the status of subspace solutions. #endregion #region Body if (IWORD == 0) { // c the subspace minimization converged. WORD = BFGSWord.con; } else { if (IWORD == 1) { // c the subspace minimization stopped at a bound. WORD = BFGSWord.bnd; } else { if (IWORD == 5) { // c the truncated Newton step has been used. WORD = BFGSWord.tnt; } else { WORD = BFGSWord.aaa; } } } if (IPRINT >= 99) { //ERROR-ERROR WRITE (6,*) 'LINE SEARCH',IBACK,' times; norm of step = ',XSTEP; //ERROR-ERROR WRITE (6,2001) ITER,F,SBGNRM; if (IPRINT > 100) { //ERROR-ERROR WRITE (6,1004) 'X =',(X(I), I = 1, N); //ERROR-ERROR WRITE (6,1004) 'G =',(G(I), I = 1, N); } } else { if (IPRINT > 0) { IMOD = FortranLib.Mod(ITER, IPRINT); if (IMOD == 0) { ; //ERROR-ERRORWRITE(6,2001)ITER,F,SBGNRM } } } if (IPRINT >= 1) { ; //ERROR-ERRORWRITE(ITFILE,3001)ITER,NFGV,NINT,NACT,WORD,IBACK,STP,XSTEP,SBGNRM,F } return; #endregion }
/// <summary> /// Purpose /// ======= /// /// DLAIC1 applies one step of incremental condition estimation in /// its simplest version: /// /// Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j /// lower triangular matrix L, such that /// twonorm(L*x) = sest /// Then DLAIC1 computes sestpr, s, c such that /// the vector /// [ s*x ] /// xhat = [ c ] /// is an approximate singular vector of /// [ L 0 ] /// Lhat = [ w' gamma ] /// in the sense that /// twonorm(Lhat*xhat) = sestpr. /// /// Depending on JOB, an estimate for the largest or smallest singular /// value is computed. /// /// Note that [s c]' and sestpr**2 is an eigenpair of the system /// /// diag(sest*sest, 0) + [alpha gamma] * [ alpha ] /// [ gamma ] /// /// where alpha = x'*w. /// ///</summary> /// <param name="JOB"> /// (input) INTEGER /// = 1: an estimate for the largest singular value is computed. /// = 2: an estimate for the smallest singular value is computed. ///</param> /// <param name="J"> /// (input) INTEGER /// Length of X and W ///</param> /// <param name="X"> /// (input) DOUBLE PRECISION array, dimension (J) /// The j-vector x. ///</param> /// <param name="SEST"> /// (input) DOUBLE PRECISION /// Estimated singular value of j by j matrix L ///</param> /// <param name="W"> /// (input) DOUBLE PRECISION array, dimension (J) /// The j-vector w. ///</param> /// <param name="GAMMA"> /// (input) DOUBLE PRECISION /// The diagonal element gamma. ///</param> /// <param name="SESTPR"> /// (output) DOUBLE PRECISION /// Estimated singular value of (j+1) by (j+1) matrix Lhat. ///</param> /// <param name="S"> /// (output) DOUBLE PRECISION /// Sine needed in forming xhat. ///</param> /// <param name="C"> /// (output) DOUBLE PRECISION /// Cosine needed in forming xhat. ///</param> public void Run(int JOB, int J, double[] X, int offset_x, double SEST, double[] W, int offset_w, double GAMMA , ref double SESTPR, ref double S, ref double C) { #region Variables double ABSALP = 0; double ABSEST = 0; double ABSGAM = 0; double ALPHA = 0; double B = 0; double COSINE = 0; double EPS = 0; double NORMA = 0; double S1 = 0; double S2 = 0; double SINE = 0; double T = 0; double TEST = 0; double TMP = 0; double ZETA1 = 0; double ZETA2 = 0; #endregion #region Array Index Correction int o_x = -1 + offset_x; int o_w = -1 + offset_w; #endregion #region Prolog // * // * -- LAPACK auxiliary routine (version 3.1) -- // * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. // * November 2006 // * // * .. Scalar Arguments .. // * .. // * .. Array Arguments .. // * .. // * // * Purpose // * ======= // * // * DLAIC1 applies one step of incremental condition estimation in // * its simplest version: // * // * Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j // * lower triangular matrix L, such that // * twonorm(L*x) = sest // * Then DLAIC1 computes sestpr, s, c such that // * the vector // * [ s*x ] // * xhat = [ c ] // * is an approximate singular vector of // * [ L 0 ] // * Lhat = [ w' gamma ] // * in the sense that // * twonorm(Lhat*xhat) = sestpr. // * // * Depending on JOB, an estimate for the largest or smallest singular // * value is computed. // * // * Note that [s c]' and sestpr**2 is an eigenpair of the system // * // * diag(sest*sest, 0) + [alpha gamma] * [ alpha ] // * [ gamma ] // * // * where alpha = x'*w. // * // * Arguments // * ========= // * // * JOB (input) INTEGER // * = 1: an estimate for the largest singular value is computed. // * = 2: an estimate for the smallest singular value is computed. // * // * J (input) INTEGER // * Length of X and W // * // * X (input) DOUBLE PRECISION array, dimension (J) // * The j-vector x. // * // * SEST (input) DOUBLE PRECISION // * Estimated singular value of j by j matrix L // * // * W (input) DOUBLE PRECISION array, dimension (J) // * The j-vector w. // * // * GAMMA (input) DOUBLE PRECISION // * The diagonal element gamma. // * // * SESTPR (output) DOUBLE PRECISION // * Estimated singular value of (j+1) by (j+1) matrix Lhat. // * // * S (output) DOUBLE PRECISION // * Sine needed in forming xhat. // * // * C (output) DOUBLE PRECISION // * Cosine needed in forming xhat. // * // * ===================================================================== // * // * .. Parameters .. // * .. // * .. Local Scalars .. // * .. // * .. Intrinsic Functions .. // INTRINSIC ABS, MAX, SIGN, SQRT; // * .. // * .. External Functions .. // * .. // * .. Executable Statements .. // * #endregion #region Body EPS = this._dlamch.Run("Epsilon"); ALPHA = this._ddot.Run(J, X, offset_x, 1, W, offset_w, 1); // * ABSALP = Math.Abs(ALPHA); ABSGAM = Math.Abs(GAMMA); ABSEST = Math.Abs(SEST); // * if (JOB == 1) { // * // * Estimating largest singular value // * // * special cases // * if (SEST == ZERO) { S1 = Math.Max(ABSGAM, ABSALP); if (S1 == ZERO) { S = ZERO; C = ONE; SESTPR = ZERO; } else { S = ALPHA / S1; C = GAMMA / S1; TMP = Math.Sqrt(S * S + C * C); S /= TMP; C /= TMP; SESTPR = S1 * TMP; } return; } else { if (ABSGAM <= EPS * ABSEST) { S = ONE; C = ZERO; TMP = Math.Max(ABSEST, ABSALP); S1 = ABSEST / TMP; S2 = ABSALP / TMP; SESTPR = TMP * Math.Sqrt(S1 * S1 + S2 * S2); return; } else { if (ABSALP <= EPS * ABSEST) { S1 = ABSGAM; S2 = ABSEST; if (S1 <= S2) { S = ONE; C = ZERO; SESTPR = S2; } else { S = ZERO; C = ONE; SESTPR = S1; } return; } else { if (ABSEST <= EPS * ABSALP || ABSEST <= EPS * ABSGAM) { S1 = ABSGAM; S2 = ABSALP; if (S1 <= S2) { TMP = S1 / S2; S = Math.Sqrt(ONE + TMP * TMP); SESTPR = S2 * S; C = (GAMMA / S2) / S; S = FortranLib.Sign(ONE, ALPHA) / S; } else { TMP = S2 / S1; C = Math.Sqrt(ONE + TMP * TMP); SESTPR = S1 * C; S = (ALPHA / S1) / C; C = FortranLib.Sign(ONE, GAMMA) / C; } return; } else { // * // * normal case // * ZETA1 = ALPHA / ABSEST; ZETA2 = GAMMA / ABSEST; // * B = (ONE - ZETA1 * ZETA1 - ZETA2 * ZETA2) * HALF; C = ZETA1 * ZETA1; if (B > ZERO) { T = C / (B + Math.Sqrt(B * B + C)); } else { T = Math.Sqrt(B * B + C) - B; } // * SINE = -ZETA1 / T; COSINE = -ZETA2 / (ONE + T); TMP = Math.Sqrt(SINE * SINE + COSINE * COSINE); S = SINE / TMP; C = COSINE / TMP; SESTPR = Math.Sqrt(T + ONE) * ABSEST; return; } } } } // * } else { if (JOB == 2) { // * // * Estimating smallest singular value // * // * special cases // * if (SEST == ZERO) { SESTPR = ZERO; if (Math.Max(ABSGAM, ABSALP) == ZERO) { SINE = ONE; COSINE = ZERO; } else { SINE = -GAMMA; COSINE = ALPHA; } S1 = Math.Max(Math.Abs(SINE), Math.Abs(COSINE)); S = SINE / S1; C = COSINE / S1; TMP = Math.Sqrt(S * S + C * C); S /= TMP; C /= TMP; return; } else { if (ABSGAM <= EPS * ABSEST) { S = ZERO; C = ONE; SESTPR = ABSGAM; return; } else { if (ABSALP <= EPS * ABSEST) { S1 = ABSGAM; S2 = ABSEST; if (S1 <= S2) { S = ZERO; C = ONE; SESTPR = S1; } else { S = ONE; C = ZERO; SESTPR = S2; } return; } else { if (ABSEST <= EPS * ABSALP || ABSEST <= EPS * ABSGAM) { S1 = ABSGAM; S2 = ABSALP; if (S1 <= S2) { TMP = S1 / S2; C = Math.Sqrt(ONE + TMP * TMP); SESTPR = ABSEST * (TMP / C); S = -(GAMMA / S2) / C; C = FortranLib.Sign(ONE, ALPHA) / C; } else { TMP = S2 / S1; S = Math.Sqrt(ONE + TMP * TMP); SESTPR = ABSEST / S; C = (ALPHA / S1) / S; S = -FortranLib.Sign(ONE, GAMMA) / S; } return; } else { // * // * normal case // * ZETA1 = ALPHA / ABSEST; ZETA2 = GAMMA / ABSEST; // * NORMA = Math.Max(ONE + ZETA1 * ZETA1 + Math.Abs(ZETA1 * ZETA2), Math.Abs(ZETA1 * ZETA2) + ZETA2 * ZETA2); // * // * See if root is closer to zero or to ONE // * TEST = ONE + TWO * (ZETA1 - ZETA2) * (ZETA1 + ZETA2); if (TEST >= ZERO) { // * // * root is close to zero, compute directly // * B = (ZETA1 * ZETA1 + ZETA2 * ZETA2 + ONE) * HALF; C = ZETA2 * ZETA2; T = C / (B + Math.Sqrt(Math.Abs(B * B - C))); SINE = ZETA1 / (ONE - T); COSINE = -ZETA2 / T; SESTPR = Math.Sqrt(T + FOUR * EPS * EPS * NORMA) * ABSEST; } else { // * // * root is closer to ONE, shift by that amount // * B = (ZETA2 * ZETA2 + ZETA1 * ZETA1 - ONE) * HALF; C = ZETA1 * ZETA1; if (B >= ZERO) { T = -C / (B + Math.Sqrt(B * B + C)); } else { T = B - Math.Sqrt(B * B + C); } SINE = -ZETA1 / T; COSINE = -ZETA2 / (ONE + T); SESTPR = Math.Sqrt(ONE + T + FOUR * EPS * EPS * NORMA) * ABSEST; } TMP = Math.Sqrt(SINE * SINE + COSINE * COSINE); S = SINE / TMP; C = COSINE / TMP; return; // * } } } } } } return; // * // * End of DLAIC1 // * #endregion }
/// <summary> /// Purpose /// ======= /// /// DORMRZ overwrites the general real M-by-N matrix C with /// /// SIDE = 'L' SIDE = 'R' /// TRANS = 'N': Q * C C * Q /// TRANS = 'T': Q**T * C C * Q**T /// /// where Q is a real orthogonal matrix defined as the product of k /// elementary reflectors /// /// Q = H(1) H(2) . . . H(k) /// /// as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N /// if SIDE = 'R'. /// ///</summary> /// <param name="SIDE"> /// = 'L' SIDE = 'R' ///</param> /// <param name="TRANS"> /// (input) CHARACTER*1 /// = 'N': No transpose, apply Q; /// = 'T': Transpose, apply Q**T. ///</param> /// <param name="M"> /// (input) INTEGER /// The number of rows of the matrix C. M .GE. 0. ///</param> /// <param name="N"> /// (input) INTEGER /// The number of columns of the matrix C. N .GE. 0. ///</param> /// <param name="K"> /// (input) INTEGER /// The number of elementary reflectors whose product defines /// the matrix Q. /// If SIDE = 'L', M .GE. K .GE. 0; /// if SIDE = 'R', N .GE. K .GE. 0. ///</param> /// <param name="L"> /// (input) INTEGER /// The number of columns of the matrix A containing /// the meaningful part of the Householder reflectors. /// If SIDE = 'L', M .GE. L .GE. 0, if SIDE = 'R', N .GE. L .GE. 0. ///</param> /// <param name="A"> /// (input) DOUBLE PRECISION array, dimension /// (LDA,M) if SIDE = 'L', /// (LDA,N) if SIDE = 'R' /// The i-th row must contain the vector which defines the /// elementary reflector H(i), for i = 1,2,...,k, as returned by /// DTZRZF in the last k rows of its array argument A. /// A is modified by the routine but restored on exit. ///</param> /// <param name="LDA"> /// (input) INTEGER /// The leading dimension of the array A. LDA .GE. max(1,K). ///</param> /// <param name="TAU"> /// (input) DOUBLE PRECISION array, dimension (K) /// TAU(i) must contain the scalar factor of the elementary /// reflector H(i), as returned by DTZRZF. ///</param> /// <param name="C"> /// (input/output) DOUBLE PRECISION array, dimension (LDC,N) /// On entry, the M-by-N matrix C. /// On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. ///</param> /// <param name="LDC"> /// (input) INTEGER /// The leading dimension of the array C. LDC .GE. max(1,M). ///</param> /// <param name="WORK"> /// (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) /// On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ///</param> /// <param name="LWORK"> /// (input) INTEGER /// The dimension of the array WORK. /// If SIDE = 'L', LWORK .GE. max(1,N); /// if SIDE = 'R', LWORK .GE. max(1,M). /// For optimum performance LWORK .GE. N*NB if SIDE = 'L', and /// LWORK .GE. M*NB if SIDE = 'R', where NB is the optimal /// blocksize. /// /// If LWORK = -1, then a workspace query is assumed; the routine /// only calculates the optimal size of the WORK array, returns /// this value as the first entry of the WORK array, and no error /// message related to LWORK is issued by XERBLA. ///</param> /// <param name="INFO"> /// (output) INTEGER /// = 0: successful exit /// .LT. 0: if INFO = -i, the i-th argument had an illegal value ///</param> public void Run(string SIDE, string TRANS, int M, int N, int K, int L , double[] A, int offset_a, int LDA, double[] TAU, int offset_tau, ref double[] C, int offset_c, int LDC, ref double[] WORK, int offset_work , int LWORK, ref int INFO) { #region Variables bool LEFT = false; bool LQUERY = false; bool NOTRAN = false; string TRANST = new string(' ', 1); int I = 0; int I1 = 0; int I2 = 0; int I3 = 0; int IB = 0; int IC = 0; int IINFO = 0; int IWS = 0; int JA = 0; int JC = 0; int LDWORK = 0; int LWKOPT = 0; int MI = 0; int NB = 0; int NBMIN = 0; int NI = 0; int NQ = 0; int NW = 0; int offset_t = 0; #endregion #region Array Index Correction int o_a = -1 - LDA + offset_a; int o_tau = -1 + offset_tau; int o_c = -1 - LDC + offset_c; int o_work = -1 + offset_work; #endregion #region Strings SIDE = SIDE.Substring(0, 1); TRANS = TRANS.Substring(0, 1); #endregion #region Prolog // * // * -- LAPACK routine (version 3.1.1) -- // * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. // * January 2007 // * // * .. Scalar Arguments .. // * .. // * .. Array Arguments .. // * .. // * // * Purpose // * ======= // * // * DORMRZ overwrites the general real M-by-N matrix C with // * // * SIDE = 'L' SIDE = 'R' // * TRANS = 'N': Q * C C * Q // * TRANS = 'T': Q**T * C C * Q**T // * // * where Q is a real orthogonal matrix defined as the product of k // * elementary reflectors // * // * Q = H(1) H(2) . . . H(k) // * // * as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N // * if SIDE = 'R'. // * // * Arguments // * ========= // * // * SIDE (input) CHARACTER*1 // * = 'L': apply Q or Q**T from the Left; // * = 'R': apply Q or Q**T from the Right. // * // * TRANS (input) CHARACTER*1 // * = 'N': No transpose, apply Q; // * = 'T': Transpose, apply Q**T. // * // * M (input) INTEGER // * The number of rows of the matrix C. M >= 0. // * // * N (input) INTEGER // * The number of columns of the matrix C. N >= 0. // * // * K (input) INTEGER // * The number of elementary reflectors whose product defines // * the matrix Q. // * If SIDE = 'L', M >= K >= 0; // * if SIDE = 'R', N >= K >= 0. // * // * L (input) INTEGER // * The number of columns of the matrix A containing // * the meaningful part of the Householder reflectors. // * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. // * // * A (input) DOUBLE PRECISION array, dimension // * (LDA,M) if SIDE = 'L', // * (LDA,N) if SIDE = 'R' // * The i-th row must contain the vector which defines the // * elementary reflector H(i), for i = 1,2,...,k, as returned by // * DTZRZF in the last k rows of its array argument A. // * A is modified by the routine but restored on exit. // * // * LDA (input) INTEGER // * The leading dimension of the array A. LDA >= max(1,K). // * // * TAU (input) DOUBLE PRECISION array, dimension (K) // * TAU(i) must contain the scalar factor of the elementary // * reflector H(i), as returned by DTZRZF. // * // * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) // * On entry, the M-by-N matrix C. // * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. // * // * LDC (input) INTEGER // * The leading dimension of the array C. LDC >= max(1,M). // * // * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) // * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. // * // * LWORK (input) INTEGER // * The dimension of the array WORK. // * If SIDE = 'L', LWORK >= max(1,N); // * if SIDE = 'R', LWORK >= max(1,M). // * For optimum performance LWORK >= N*NB if SIDE = 'L', and // * LWORK >= M*NB if SIDE = 'R', where NB is the optimal // * blocksize. // * // * If LWORK = -1, then a workspace query is assumed; the routine // * only calculates the optimal size of the WORK array, returns // * this value as the first entry of the WORK array, and no error // * message related to LWORK is issued by XERBLA. // * // * INFO (output) INTEGER // * = 0: successful exit // * < 0: if INFO = -i, the i-th argument had an illegal value // * // * Further Details // * =============== // * // * Based on contributions by // * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA // * // * ===================================================================== // * // * .. Parameters .. // * .. // * .. Local Scalars .. // * .. // * .. Local Arrays .. // * .. // * .. External Functions .. // * .. // * .. External Subroutines .. // * .. // * .. Intrinsic Functions .. // INTRINSIC MAX, MIN; // * .. // * .. Executable Statements .. // * // * Test the input arguments // * #endregion #region Body INFO = 0; LEFT = this._lsame.Run(SIDE, "L"); NOTRAN = this._lsame.Run(TRANS, "N"); LQUERY = (LWORK == -1); // * // * NQ is the order of Q and NW is the minimum dimension of WORK // * if (LEFT) { NQ = M; NW = Math.Max(1, N); } else { NQ = N; NW = Math.Max(1, M); } if (!LEFT && !this._lsame.Run(SIDE, "R")) { INFO = -1; } else { if (!NOTRAN && !this._lsame.Run(TRANS, "T")) { INFO = -2; } else { if (M < 0) { INFO = -3; } else { if (N < 0) { INFO = -4; } else { if (K < 0 || K > NQ) { INFO = -5; } else { if (L < 0 || (LEFT && (L > M)) || (!LEFT && (L > N))) { INFO = -6; } else { if (LDA < Math.Max(1, K)) { INFO = -8; } else { if (LDC < Math.Max(1, M)) { INFO = -11; } } } } } } } } // * if (INFO == 0) { if (M == 0 || N == 0) { LWKOPT = 1; } else { // * // * Determine the block size. NB may be at most NBMAX, where // * NBMAX is used to define the local array T. // * NB = Math.Min(NBMAX, this._ilaenv.Run(1, "DORMRQ", SIDE + TRANS, M, N, K, -1)); LWKOPT = NW * NB; } WORK[1 + o_work] = LWKOPT; // * if (LWORK < Math.Max(1, NW) && !LQUERY) { INFO = -13; } } // * if (INFO != 0) { this._xerbla.Run("DORMRZ", -INFO); return; } else { if (LQUERY) { return; } } // * // * Quick return if possible // * if (M == 0 || N == 0) { WORK[1 + o_work] = 1; return; } // * NBMIN = 2; LDWORK = NW; if (NB > 1 && NB < K) { IWS = NW * NB; if (LWORK < IWS) { NB = LWORK / LDWORK; NBMIN = Math.Max(2, this._ilaenv.Run(2, "DORMRQ", SIDE + TRANS, M, N, K, -1)); } } else { IWS = NW; } // * if (NB < NBMIN || NB >= K) { // * // * Use unblocked code // * this._dormr3.Run(SIDE, TRANS, M, N, K, L , A, offset_a, LDA, TAU, offset_tau, ref C, offset_c, LDC, ref WORK, offset_work , ref IINFO); } else { // * // * Use blocked code // * if ((LEFT && !NOTRAN) || (!LEFT && NOTRAN)) { I1 = 1; I2 = K; I3 = NB; } else { I1 = ((K - 1) / NB) * NB + 1; I2 = 1; I3 = -NB; } // * if (LEFT) { NI = N; JC = 1; JA = M - L + 1; } else { MI = M; IC = 1; JA = N - L + 1; } // * if (NOTRAN) { FortranLib.Copy(ref TRANST, "T"); } else { FortranLib.Copy(ref TRANST, "N"); } // * for (I = I1; (I3 >= 0) ? (I <= I2) : (I >= I2); I += I3) { IB = Math.Min(NB, K - I + 1); // * // * Form the triangular factor of the block reflector // * H = H(i+ib-1) . . . H(i+1) H(i) // * this._dlarzt.Run("Backward", "Rowwise", L, IB, A, I + JA * LDA + o_a, LDA , TAU, I + o_tau, ref T, offset_t, LDT); // * if (LEFT) { // * // * H or H' is applied to C(i:m,1:n) // * MI = M - I + 1; IC = I; } else { // * // * H or H' is applied to C(1:m,i:n) // * NI = N - I + 1; JC = I; } // * // * Apply H or H' // * this._dlarzb.Run(SIDE, TRANST, "Backward", "Rowwise", MI, NI , IB, L, A, I + JA * LDA + o_a, LDA, T, offset_t, LDT , ref C, IC + JC * LDC + o_c, LDC, ref WORK, offset_work, LDWORK); } // * } // * WORK[1 + o_work] = LWKOPT; // * return; // * // * End of DORMRZ // * #endregion }
/// <summary> /// Purpose /// ======= /// /// DLASV2 computes the singular value decomposition of a 2-by-2 /// triangular matrix /// [ F G ] /// [ 0 H ]. /// On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the /// smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and /// right singular vectors for abs(SSMAX), giving the decomposition /// /// [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] /// [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. /// ///</summary> /// <param name="F"> /// (input) DOUBLE PRECISION /// The (1,1) element of the 2-by-2 matrix. ///</param> /// <param name="G"> /// (input) DOUBLE PRECISION /// The (1,2) element of the 2-by-2 matrix. ///</param> /// <param name="H"> /// (input) DOUBLE PRECISION /// The (2,2) element of the 2-by-2 matrix. ///</param> /// <param name="SSMIN"> /// (output) DOUBLE PRECISION /// abs(SSMIN) is the smaller singular value. ///</param> /// <param name="SSMAX"> /// (output) DOUBLE PRECISION /// abs(SSMAX) is the larger singular value. ///</param> /// <param name="SNR"> /// (output) DOUBLE PRECISION ///</param> /// <param name="CSR"> /// (output) DOUBLE PRECISION /// The vector (CSR, SNR) is a unit right singular vector for the /// singular value abs(SSMAX). ///</param> /// <param name="SNL"> /// (output) DOUBLE PRECISION ///</param> /// <param name="CSL"> /// (output) DOUBLE PRECISION /// The vector (CSL, SNL) is a unit left singular vector for the /// singular value abs(SSMAX). ///</param> public void Run(double F, double G, double H, ref double SSMIN, ref double SSMAX, ref double SNR , ref double CSR, ref double SNL, ref double CSL) { #region Variables bool GASMAL = false; bool SWAP = false; int PMAX = 0; double A = 0; double CLT = 0; double CRT = 0; double D = 0; double FA = 0; double FT = 0; double GA = 0; double GT = 0; double HA = 0; double HT = 0; double L = 0; double M = 0; double MM = 0; double R = 0; double S = 0; double SLT = 0; double SRT = 0; double T = 0; double TEMP = 0; double TSIGN = 0; double TT = 0; #endregion #region Prolog // * // * -- LAPACK auxiliary routine (version 3.1) -- // * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. // * November 2006 // * // * .. Scalar Arguments .. // * .. // * // * Purpose // * ======= // * // * DLASV2 computes the singular value decomposition of a 2-by-2 // * triangular matrix // * [ F G ] // * [ 0 H ]. // * On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the // * smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and // * right singular vectors for abs(SSMAX), giving the decomposition // * // * [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] // * [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. // * // * Arguments // * ========= // * // * F (input) DOUBLE PRECISION // * The (1,1) element of the 2-by-2 matrix. // * // * G (input) DOUBLE PRECISION // * The (1,2) element of the 2-by-2 matrix. // * // * H (input) DOUBLE PRECISION // * The (2,2) element of the 2-by-2 matrix. // * // * SSMIN (output) DOUBLE PRECISION // * abs(SSMIN) is the smaller singular value. // * // * SSMAX (output) DOUBLE PRECISION // * abs(SSMAX) is the larger singular value. // * // * SNL (output) DOUBLE PRECISION // * CSL (output) DOUBLE PRECISION // * The vector (CSL, SNL) is a unit left singular vector for the // * singular value abs(SSMAX). // * // * SNR (output) DOUBLE PRECISION // * CSR (output) DOUBLE PRECISION // * The vector (CSR, SNR) is a unit right singular vector for the // * singular value abs(SSMAX). // * // * Further Details // * =============== // * // * Any input parameter may be aliased with any output parameter. // * // * Barring over/underflow and assuming a guard digit in subtraction, all // * output quantities are correct to within a few units in the last // * place (ulps). // * // * In IEEE arithmetic, the code works correctly if one matrix element is // * infinite. // * // * Overflow will not occur unless the largest singular value itself // * overflows or is within a few ulps of overflow. (On machines with // * partial overflow, like the Cray, overflow may occur if the largest // * singular value is within a factor of 2 of overflow.) // * // * Underflow is harmless if underflow is gradual. Otherwise, results // * may correspond to a matrix modified by perturbations of size near // * the underflow threshold. // * // * ===================================================================== // * // * .. Parameters .. // * .. // * .. Local Scalars .. // * .. // * .. Intrinsic Functions .. // INTRINSIC ABS, SIGN, SQRT; // * .. // * .. External Functions .. // * .. // * .. Executable Statements .. // * #endregion #region Body FT = F; FA = Math.Abs(FT); HT = H; HA = Math.Abs(H); // * // * PMAX points to the maximum absolute element of matrix // * PMAX = 1 if F largest in absolute values // * PMAX = 2 if G largest in absolute values // * PMAX = 3 if H largest in absolute values // * PMAX = 1; SWAP = (HA > FA); if (SWAP) { PMAX = 3; TEMP = FT; FT = HT; HT = TEMP; TEMP = FA; FA = HA; HA = TEMP; // * // * Now FA .ge. HA // * } GT = G; GA = Math.Abs(GT); if (GA == ZERO) { // * // * Diagonal matrix // * SSMIN = HA; SSMAX = FA; CLT = ONE; CRT = ONE; SLT = ZERO; SRT = ZERO; } else { GASMAL = true; if (GA > FA) { PMAX = 2; if ((FA / GA) < this._dlamch.Run("EPS")) { // * // * Case of very large GA // * GASMAL = false; SSMAX = GA; if (HA > ONE) { SSMIN = FA / (GA / HA); } else { SSMIN = (FA / GA) * HA; } CLT = ONE; SLT = HT / GT; SRT = ONE; CRT = FT / GT; } } if (GASMAL) { // * // * Normal case // * D = FA - HA; if (D == FA) { // * // * Copes with infinite F or H // * L = ONE; } else { L = D / FA; } // * // * Note that 0 .le. L .le. 1 // * M = GT / FT; // * // * Note that abs(M) .le. 1/macheps // * T = TWO - L; // * // * Note that T .ge. 1 // * MM = M * M; TT = T * T; S = Math.Sqrt(TT + MM); // * // * Note that 1 .le. S .le. 1 + 1/macheps // * if (L == ZERO) { R = Math.Abs(M); } else { R = Math.Sqrt(L * L + MM); } // * // * Note that 0 .le. R .le. 1 + 1/macheps // * A = HALF * (S + R); // * // * Note that 1 .le. A .le. 1 + abs(M) // * SSMIN = HA / A; SSMAX = FA * A; if (MM == ZERO) { // * // * Note that M is very tiny // * if (L == ZERO) { T = FortranLib.Sign(TWO, FT) * FortranLib.Sign(ONE, GT); } else { T = GT / FortranLib.Sign(D, FT) + M / T; } } else { T = (M / (S + T) + M / (R + L)) * (ONE + A); } L = Math.Sqrt(T * T + FOUR); CRT = TWO / L; SRT = T / L; CLT = (CRT + SRT * M) / A; SLT = (HT / FT) * SRT / A; } } if (SWAP) { CSL = SRT; SNL = CRT; CSR = SLT; SNR = CLT; } else { CSL = CLT; SNL = SLT; CSR = CRT; SNR = SRT; } // * // * Correct signs of SSMAX and SSMIN // * if (PMAX == 1) { TSIGN = FortranLib.Sign(ONE, CSR) * FortranLib.Sign(ONE, CSL) * FortranLib.Sign(ONE, F); } if (PMAX == 2) { TSIGN = FortranLib.Sign(ONE, SNR) * FortranLib.Sign(ONE, CSL) * FortranLib.Sign(ONE, G); } if (PMAX == 3) { TSIGN = FortranLib.Sign(ONE, SNR) * FortranLib.Sign(ONE, SNL) * FortranLib.Sign(ONE, H); } SSMAX = FortranLib.Sign(SSMAX, TSIGN); SSMIN = FortranLib.Sign(SSMIN, TSIGN * FortranLib.Sign(ONE, F) * FortranLib.Sign(ONE, H)); return; // * // * End of DLASV2 // * #endregion }
public void Run(int N, int M, double[] X, int offset_x, double[] G, int offset_g, double[] WS, int offset_ws, double[] WY, int offset_wy , double[] SY, int offset_sy, double[] WT, int offset_wt, double[] Z, int offset_z, ref double[] R, int offset_r, ref double[] WA, int offset_wa, int[] INDEX, int offset_index , double THETA, int COL, int HEAD, int NFREE, bool CNSTND, ref int INFO) { #region Variables int I = 0; int J = 0; int K = 0; int POINTR = 0; double A1 = 0; double A2 = 0; #endregion #region Array Index Correction int o_x = -1 + offset_x; int o_g = -1 + offset_g; int o_ws = -1 - N + offset_ws; int o_wy = -1 - N + offset_wy; int o_sy = -1 - M + offset_sy; int o_wt = -1 - M + offset_wt; int o_z = -1 + offset_z; int o_r = -1 + offset_r; int o_wa = -1 + offset_wa; int o_index = -1 + offset_index; #endregion #region Prolog // c ************ // c // c Subroutine cmprlb // c // c This subroutine computes r=-Z'B(xcp-xk)-Z'g by using // c wa(2m+1)=W'(xcp-x) from subroutine cauchy. // c // c Subprograms called: // c // c L-BFGS-B Library ... bmv. // c // c // c * * * // c // c NEOS, November 1994. (Latest revision June 1996.) // c Optimization Technology Center. // c Argonne National Laboratory and Northwestern University. // c Written by // c Ciyou Zhu // c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. // c // c // c ************ #endregion #region Body if (!CNSTND && COL > 0) { for (I = 1; I <= N; I++) { R[I + o_r] = -G[I + o_g]; } } else { for (I = 1; I <= NFREE; I++) { K = INDEX[I + o_index]; R[I + o_r] = -THETA * (Z[K + o_z] - X[K + o_x]) - G[K + o_g]; } this._bmv.Run(M, SY, offset_sy, WT, offset_wt, COL, WA, 2 * M + 1 + o_wa, ref WA, 1 + o_wa , ref INFO); if (INFO != 0) { INFO = -8; return; } POINTR = HEAD; for (J = 1; J <= COL; J++) { A1 = WA[J + o_wa]; A2 = THETA * WA[COL + J + o_wa]; for (I = 1; I <= NFREE; I++) { K = INDEX[I + o_index]; R[I + o_r] += WY[K + POINTR * N + o_wy] * A1 + WS[K + POINTR * N + o_ws] * A2; } POINTR = FortranLib.Mod(POINTR, M) + 1; } } return; #endregion }
/// <summary> /// Purpose /// ======= /// /// DBDSQR computes the singular values and, optionally, the right and/or /// left singular vectors from the singular value decomposition (SVD) of /// a real N-by-N (upper or lower) bidiagonal matrix B using the implicit /// zero-shift QR algorithm. The SVD of B has the form /// /// B = Q * S * P**T /// /// where S is the diagonal matrix of singular values, Q is an orthogonal /// matrix of left singular vectors, and P is an orthogonal matrix of /// right singular vectors. If left singular vectors are requested, this /// subroutine actually returns U*Q instead of Q, and, if right singular /// vectors are requested, this subroutine returns P**T*VT instead of /// P**T, for given real input matrices U and VT. When U and VT are the /// orthogonal matrices that reduce a general matrix A to bidiagonal /// form: A = U*B*VT, as computed by DGEBRD, then /// /// A = (U*Q) * S * (P**T*VT) /// /// is the SVD of A. Optionally, the subroutine may also compute Q**T*C /// for a given real input matrix C. /// /// See "Computing Small Singular Values of Bidiagonal Matrices With /// Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, /// LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, /// no. 5, pp. 873-912, Sept 1990) and /// "Accurate singular values and differential qd algorithms," by /// B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics /// Department, University of California at Berkeley, July 1992 /// for a detailed description of the algorithm. /// ///</summary> /// <param name="UPLO"> /// (input) CHARACTER*1 /// = 'U': B is upper bidiagonal; /// = 'L': B is lower bidiagonal. ///</param> /// <param name="N"> /// (input) INTEGER /// The order of the matrix B. N .GE. 0. ///</param> /// <param name="NCVT"> /// (input) INTEGER /// The number of columns of the matrix VT. NCVT .GE. 0. ///</param> /// <param name="NRU"> /// (input) INTEGER /// The number of rows of the matrix U. NRU .GE. 0. ///</param> /// <param name="NCC"> /// (input) INTEGER /// The number of columns of the matrix C. NCC .GE. 0. ///</param> /// <param name="D"> /// (input/output) DOUBLE PRECISION array, dimension (N) /// On entry, the n diagonal elements of the bidiagonal matrix B. /// On exit, if INFO=0, the singular values of B in decreasing /// order. ///</param> /// <param name="E"> /// (input/output) DOUBLE PRECISION array, dimension (N-1) /// On entry, the N-1 offdiagonal elements of the bidiagonal /// matrix B. /// On exit, if INFO = 0, E is destroyed; if INFO .GT. 0, D and E /// will contain the diagonal and superdiagonal elements of a /// bidiagonal matrix orthogonally equivalent to the one given /// as input. ///</param> /// <param name="VT"> /// (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) /// On entry, an N-by-NCVT matrix VT. /// On exit, VT is overwritten by P**T * VT. /// Not referenced if NCVT = 0. ///</param> /// <param name="LDVT"> /// (input) INTEGER /// The leading dimension of the array VT. /// LDVT .GE. max(1,N) if NCVT .GT. 0; LDVT .GE. 1 if NCVT = 0. ///</param> /// <param name="U"> /// (input/output) DOUBLE PRECISION array, dimension (LDU, N) /// On entry, an NRU-by-N matrix U. /// On exit, U is overwritten by U * Q. /// Not referenced if NRU = 0. ///</param> /// <param name="LDU"> /// (input) INTEGER /// The leading dimension of the array U. LDU .GE. max(1,NRU). ///</param> /// <param name="C"> /// (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) /// On entry, an N-by-NCC matrix C. /// On exit, C is overwritten by Q**T * C. /// Not referenced if NCC = 0. ///</param> /// <param name="LDC"> /// (input) INTEGER /// The leading dimension of the array C. /// LDC .GE. max(1,N) if NCC .GT. 0; LDC .GE.1 if NCC = 0. ///</param> /// <param name="WORK"> /// (workspace) DOUBLE PRECISION array, dimension (2*N) /// if NCVT = NRU = NCC = 0, (max(1, 4*N)) otherwise ///</param> /// <param name="INFO"> /// (output) INTEGER /// = 0: successful exit /// .LT. 0: If INFO = -i, the i-th argument had an illegal value /// .GT. 0: the algorithm did not converge; D and E contain the /// elements of a bidiagonal matrix which is orthogonally /// similar to the input matrix B; if INFO = i, i /// elements of E have not converged to zero. ///</param> public void Run(string UPLO, int N, int NCVT, int NRU, int NCC, ref double[] D, int offset_d , ref double[] E, int offset_e, ref double[] VT, int offset_vt, int LDVT, ref double[] U, int offset_u, int LDU, ref double[] C, int offset_c , int LDC, ref double[] WORK, int offset_work, ref int INFO) { #region Variables bool LOWER = false; bool ROTATE = false; int I = 0; int IDIR = 0; int ISUB = 0; int ITER = 0; int J = 0; int LL = 0; int LLL = 0; int M = 0; int MAXIT = 0; int NM1 = 0; int NM12 = 0; int NM13 = 0; int OLDLL = 0; int OLDM = 0; double ABSE = 0; double ABSS = 0; double COSL = 0; double COSR = 0; double CS = 0; double EPS = 0; double F = 0; double G = 0; double H = 0; double MU = 0; double OLDCS = 0; double OLDSN = 0; double R = 0; double SHIFT = 0; double SIGMN = 0; double SIGMX = 0; double SINL = 0; double SINR = 0; double SLL = 0; double SMAX = 0; double SMIN = 0; double SMINL = 0; double SMINOA = 0; double SN = 0; double THRESH = 0; double TOL = 0; double TOLMUL = 0; double UNFL = 0; #endregion #region Array Index Correction int o_d = -1 + offset_d; int o_e = -1 + offset_e; int o_vt = -1 - LDVT + offset_vt; int o_u = -1 - LDU + offset_u; int o_c = -1 - LDC + offset_c; int o_work = -1 + offset_work; #endregion #region Strings UPLO = UPLO.Substring(0, 1); #endregion #region Prolog // * // * -- LAPACK routine (version 3.1.1) -- // * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. // * January 2007 // * // * .. Scalar Arguments .. // * .. // * .. Array Arguments .. // * .. // * // * Purpose // * ======= // * // * DBDSQR computes the singular values and, optionally, the right and/or // * left singular vectors from the singular value decomposition (SVD) of // * a real N-by-N (upper or lower) bidiagonal matrix B using the implicit // * zero-shift QR algorithm. The SVD of B has the form // * // * B = Q * S * P**T // * // * where S is the diagonal matrix of singular values, Q is an orthogonal // * matrix of left singular vectors, and P is an orthogonal matrix of // * right singular vectors. If left singular vectors are requested, this // * subroutine actually returns U*Q instead of Q, and, if right singular // * vectors are requested, this subroutine returns P**T*VT instead of // * P**T, for given real input matrices U and VT. When U and VT are the // * orthogonal matrices that reduce a general matrix A to bidiagonal // * form: A = U*B*VT, as computed by DGEBRD, then // * // * A = (U*Q) * S * (P**T*VT) // * // * is the SVD of A. Optionally, the subroutine may also compute Q**T*C // * for a given real input matrix C. // * // * See "Computing Small Singular Values of Bidiagonal Matrices With // * Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, // * LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, // * no. 5, pp. 873-912, Sept 1990) and // * "Accurate singular values and differential qd algorithms," by // * B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics // * Department, University of California at Berkeley, July 1992 // * for a detailed description of the algorithm. // * // * Arguments // * ========= // * // * UPLO (input) CHARACTER*1 // * = 'U': B is upper bidiagonal; // * = 'L': B is lower bidiagonal. // * // * N (input) INTEGER // * The order of the matrix B. N >= 0. // * // * NCVT (input) INTEGER // * The number of columns of the matrix VT. NCVT >= 0. // * // * NRU (input) INTEGER // * The number of rows of the matrix U. NRU >= 0. // * // * NCC (input) INTEGER // * The number of columns of the matrix C. NCC >= 0. // * // * D (input/output) DOUBLE PRECISION array, dimension (N) // * On entry, the n diagonal elements of the bidiagonal matrix B. // * On exit, if INFO=0, the singular values of B in decreasing // * order. // * // * E (input/output) DOUBLE PRECISION array, dimension (N-1) // * On entry, the N-1 offdiagonal elements of the bidiagonal // * matrix B. // * On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E // * will contain the diagonal and superdiagonal elements of a // * bidiagonal matrix orthogonally equivalent to the one given // * as input. // * // * VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) // * On entry, an N-by-NCVT matrix VT. // * On exit, VT is overwritten by P**T * VT. // * Not referenced if NCVT = 0. // * // * LDVT (input) INTEGER // * The leading dimension of the array VT. // * LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. // * // * U (input/output) DOUBLE PRECISION array, dimension (LDU, N) // * On entry, an NRU-by-N matrix U. // * On exit, U is overwritten by U * Q. // * Not referenced if NRU = 0. // * // * LDU (input) INTEGER // * The leading dimension of the array U. LDU >= max(1,NRU). // * // * C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) // * On entry, an N-by-NCC matrix C. // * On exit, C is overwritten by Q**T * C. // * Not referenced if NCC = 0. // * // * LDC (input) INTEGER // * The leading dimension of the array C. // * LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. // * // * WORK (workspace) DOUBLE PRECISION array, dimension (2*N) // * if NCVT = NRU = NCC = 0, (max(1, 4*N)) otherwise // * // * INFO (output) INTEGER // * = 0: successful exit // * < 0: If INFO = -i, the i-th argument had an illegal value // * > 0: the algorithm did not converge; D and E contain the // * elements of a bidiagonal matrix which is orthogonally // * similar to the input matrix B; if INFO = i, i // * elements of E have not converged to zero. // * // * Internal Parameters // * =================== // * // * TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) // * TOLMUL controls the convergence criterion of the QR loop. // * If it is positive, TOLMUL*EPS is the desired relative // * precision in the computed singular values. // * If it is negative, abs(TOLMUL*EPS*sigma_max) is the // * desired absolute accuracy in the computed singular // * values (corresponds to relative accuracy // * abs(TOLMUL*EPS) in the largest singular value. // * abs(TOLMUL) should be between 1 and 1/EPS, and preferably // * between 10 (for fast convergence) and .1/EPS // * (for there to be some accuracy in the results). // * Default is to lose at either one eighth or 2 of the // * available decimal digits in each computed singular value // * (whichever is smaller). // * // * MAXITR INTEGER, default = 6 // * MAXITR controls the maximum number of passes of the // * algorithm through its inner loop. The algorithms stops // * (and so fails to converge) if the number of passes // * through the inner loop exceeds MAXITR*N**2. // * // * ===================================================================== // * // * .. Parameters .. // * .. // * .. Local Scalars .. // * .. // * .. External Functions .. // * .. // * .. External Subroutines .. // * .. // * .. Intrinsic Functions .. // INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT; // * .. // * .. Executable Statements .. // * // * Test the input parameters. // * #endregion #region Body INFO = 0; LOWER = this._lsame.Run(UPLO, "L"); if (!this._lsame.Run(UPLO, "U") && !LOWER) { INFO = -1; } else { if (N < 0) { INFO = -2; } else { if (NCVT < 0) { INFO = -3; } else { if (NRU < 0) { INFO = -4; } else { if (NCC < 0) { INFO = -5; } else { if ((NCVT == 0 && LDVT < 1) || (NCVT > 0 && LDVT < Math.Max(1, N))) { INFO = -9; } else { if (LDU < Math.Max(1, NRU)) { INFO = -11; } else { if ((NCC == 0 && LDC < 1) || (NCC > 0 && LDC < Math.Max(1, N))) { INFO = -13; } } } } } } } } if (INFO != 0) { this._xerbla.Run("DBDSQR", -INFO); return; } if (N == 0) { return; } if (N == 1) { goto LABEL160; } // * // * ROTATE is true if any singular vectors desired, false otherwise // * ROTATE = (NCVT > 0) || (NRU > 0) || (NCC > 0); // * // * If no singular vectors desired, use qd algorithm // * if (!ROTATE) { this._dlasq1.Run(N, ref D, offset_d, E, offset_e, ref WORK, offset_work, ref INFO); return; } // * NM1 = N - 1; NM12 = NM1 + NM1; NM13 = NM12 + NM1; IDIR = 0; // * // * Get machine constants // * EPS = this._dlamch.Run("Epsilon"); UNFL = this._dlamch.Run("Safe minimum"); // * // * If matrix lower bidiagonal, rotate to be upper bidiagonal // * by applying Givens rotations on the left // * if (LOWER) { for (I = 1; I <= N - 1; I++) { this._dlartg.Run(D[I + o_d], E[I + o_e], ref CS, ref SN, ref R); D[I + o_d] = R; E[I + o_e] = SN * D[I + 1 + o_d]; D[I + 1 + o_d] *= CS; WORK[I + o_work] = CS; WORK[NM1 + I + o_work] = SN; } // * // * Update singular vectors if desired // * if (NRU > 0) { this._dlasr.Run("R", "V", "F", NRU, N, WORK, 1 + o_work , WORK, N + o_work, ref U, offset_u, LDU); } if (NCC > 0) { this._dlasr.Run("L", "V", "F", N, NCC, WORK, 1 + o_work , WORK, N + o_work, ref C, offset_c, LDC); } } // * // * Compute singular values to relative accuracy TOL // * (By setting TOL to be negative, algorithm will compute // * singular values to absolute accuracy ABS(TOL)*norm(input matrix)) // * TOLMUL = Math.Max(TEN, Math.Min(HNDRD, Math.Pow(EPS, MEIGTH))); TOL = TOLMUL * EPS; // * // * Compute approximate maximum, minimum singular values // * SMAX = ZERO; for (I = 1; I <= N; I++) { SMAX = Math.Max(SMAX, Math.Abs(D[I + o_d])); } for (I = 1; I <= N - 1; I++) { SMAX = Math.Max(SMAX, Math.Abs(E[I + o_e])); } SMINL = ZERO; if (TOL >= ZERO) { // * // * Relative accuracy desired // * SMINOA = Math.Abs(D[1 + o_d]); if (SMINOA == ZERO) { goto LABEL50; } MU = SMINOA; for (I = 2; I <= N; I++) { MU = Math.Abs(D[I + o_d]) * (MU / (MU + Math.Abs(E[I - 1 + o_e]))); SMINOA = Math.Min(SMINOA, MU); if (SMINOA == ZERO) { goto LABEL50; } } LABEL50 :; SMINOA /= Math.Sqrt(Convert.ToDouble(N)); THRESH = Math.Max(TOL * SMINOA, MAXITR * N * N * UNFL); } else { // * // * Absolute accuracy desired // * THRESH = Math.Max(Math.Abs(TOL) * SMAX, MAXITR * N * N * UNFL); } // * // * Prepare for main iteration loop for the singular values // * (MAXIT is the maximum number of passes through the inner // * loop permitted before nonconvergence signalled.) // * MAXIT = MAXITR * N * N; ITER = 0; OLDLL = -1; OLDM = -1; // * // * M points to last element of unconverged part of matrix // * M = N; // * // * Begin main iteration loop // * LABEL60 :; // * // * Check for convergence or exceeding iteration count // * if (M <= 1) { goto LABEL160; } if (ITER > MAXIT) { goto LABEL200; } // * // * Find diagonal block of matrix to work on // * if (TOL < ZERO && Math.Abs(D[M + o_d]) <= THRESH) { D[M + o_d] = ZERO; } SMAX = Math.Abs(D[M + o_d]); SMIN = SMAX; for (LLL = 1; LLL <= M - 1; LLL++) { LL = M - LLL; ABSS = Math.Abs(D[LL + o_d]); ABSE = Math.Abs(E[LL + o_e]); if (TOL < ZERO && ABSS <= THRESH) { D[LL + o_d] = ZERO; } if (ABSE <= THRESH) { goto LABEL80; } SMIN = Math.Min(SMIN, ABSS); SMAX = Math.Max(SMAX, Math.Max(ABSS, ABSE)); } LL = 0; goto LABEL90; LABEL80 :; E[LL + o_e] = ZERO; // * // * Matrix splits since E(LL) = 0 // * if (LL == M - 1) { // * // * Convergence of bottom singular value, return to top of loop // * M -= 1; goto LABEL60; } LABEL90 :; LL += 1; // * // * E(LL) through E(M-1) are nonzero, E(LL-1) is zero // * if (LL == M - 1) { // * // * 2 by 2 block, handle separately // * this._dlasv2.Run(D[M - 1 + o_d], E[M - 1 + o_e], D[M + o_d], ref SIGMN, ref SIGMX, ref SINR , ref COSR, ref SINL, ref COSL); D[M - 1 + o_d] = SIGMX; E[M - 1 + o_e] = ZERO; D[M + o_d] = SIGMN; // * // * Compute singular vectors, if desired // * if (NCVT > 0) { this._drot.Run(NCVT, ref VT, M - 1 + 1 * LDVT + o_vt, LDVT, ref VT, M + 1 * LDVT + o_vt, LDVT, COSR , SINR); } if (NRU > 0) { this._drot.Run(NRU, ref U, 1 + (M - 1) * LDU + o_u, 1, ref U, 1 + M * LDU + o_u, 1, COSL , SINL); } if (NCC > 0) { this._drot.Run(NCC, ref C, M - 1 + 1 * LDC + o_c, LDC, ref C, M + 1 * LDC + o_c, LDC, COSL , SINL); } M -= 2; goto LABEL60; } // * // * If working on new submatrix, choose shift direction // * (from larger end diagonal element towards smaller) // * if (LL > OLDM || M < OLDLL) { if (Math.Abs(D[LL + o_d]) >= Math.Abs(D[M + o_d])) { // * // * Chase bulge from top (big end) to bottom (small end) // * IDIR = 1; } else { // * // * Chase bulge from bottom (big end) to top (small end) // * IDIR = 2; } } // * // * Apply convergence tests // * if (IDIR == 1) { // * // * Run convergence test in forward direction // * First apply standard test to bottom of matrix // * if (Math.Abs(E[M - 1 + o_e]) <= Math.Abs(TOL) * Math.Abs(D[M + o_d]) || (TOL < ZERO && Math.Abs(E[M - 1 + o_e]) <= THRESH)) { E[M - 1 + o_e] = ZERO; goto LABEL60; } // * if (TOL >= ZERO) { // * // * If relative accuracy desired, // * apply convergence criterion forward // * MU = Math.Abs(D[LL + o_d]); SMINL = MU; for (LLL = LL; LLL <= M - 1; LLL++) { if (Math.Abs(E[LLL + o_e]) <= TOL * MU) { E[LLL + o_e] = ZERO; goto LABEL60; } MU = Math.Abs(D[LLL + 1 + o_d]) * (MU / (MU + Math.Abs(E[LLL + o_e]))); SMINL = Math.Min(SMINL, MU); } } // * } else { // * // * Run convergence test in backward direction // * First apply standard test to top of matrix // * if (Math.Abs(E[LL + o_e]) <= Math.Abs(TOL) * Math.Abs(D[LL + o_d]) || (TOL < ZERO && Math.Abs(E[LL + o_e]) <= THRESH)) { E[LL + o_e] = ZERO; goto LABEL60; } // * if (TOL >= ZERO) { // * // * If relative accuracy desired, // * apply convergence criterion backward // * MU = Math.Abs(D[M + o_d]); SMINL = MU; for (LLL = M - 1; LLL >= LL; LLL += -1) { if (Math.Abs(E[LLL + o_e]) <= TOL * MU) { E[LLL + o_e] = ZERO; goto LABEL60; } MU = Math.Abs(D[LLL + o_d]) * (MU / (MU + Math.Abs(E[LLL + o_e]))); SMINL = Math.Min(SMINL, MU); } } } OLDLL = LL; OLDM = M; // * // * Compute shift. First, test if shifting would ruin relative // * accuracy, and if so set the shift to zero. // * if (TOL >= ZERO && N * TOL * (SMINL / SMAX) <= Math.Max(EPS, HNDRTH * TOL)) { // * // * Use a zero shift to avoid loss of relative accuracy // * SHIFT = ZERO; } else { // * // * Compute the shift from 2-by-2 block at end of matrix // * if (IDIR == 1) { SLL = Math.Abs(D[LL + o_d]); this._dlas2.Run(D[M - 1 + o_d], E[M - 1 + o_e], D[M + o_d], ref SHIFT, ref R); } else { SLL = Math.Abs(D[M + o_d]); this._dlas2.Run(D[LL + o_d], E[LL + o_e], D[LL + 1 + o_d], ref SHIFT, ref R); } // * // * Test if shift negligible, and if so set to zero // * if (SLL > ZERO) { if (Math.Pow(SHIFT / SLL, 2) < EPS) { SHIFT = ZERO; } } } // * // * Increment iteration count // * ITER += M - LL; // * // * If SHIFT = 0, do simplified QR iteration // * if (SHIFT == ZERO) { if (IDIR == 1) { // * // * Chase bulge from top to bottom // * Save cosines and sines for later singular vector updates // * CS = ONE; OLDCS = ONE; for (I = LL; I <= M - 1; I++) { this._dlartg.Run(D[I + o_d] * CS, E[I + o_e], ref CS, ref SN, ref R); if (I > LL) { E[I - 1 + o_e] = OLDSN * R; } this._dlartg.Run(OLDCS * R, D[I + 1 + o_d] * SN, ref OLDCS, ref OLDSN, ref D[I + o_d]); WORK[I - LL + 1 + o_work] = CS; WORK[I - LL + 1 + NM1 + o_work] = SN; WORK[I - LL + 1 + NM12 + o_work] = OLDCS; WORK[I - LL + 1 + NM13 + o_work] = OLDSN; } H = D[M + o_d] * CS; D[M + o_d] = H * OLDCS; E[M - 1 + o_e] = H * OLDSN; // * // * Update singular vectors // * if (NCVT > 0) { this._dlasr.Run("L", "V", "F", M - LL + 1, NCVT, WORK, 1 + o_work , WORK, N + o_work, ref VT, LL + 1 * LDVT + o_vt, LDVT); } if (NRU > 0) { this._dlasr.Run("R", "V", "F", NRU, M - LL + 1, WORK, NM12 + 1 + o_work , WORK, NM13 + 1 + o_work, ref U, 1 + LL * LDU + o_u, LDU); } if (NCC > 0) { this._dlasr.Run("L", "V", "F", M - LL + 1, NCC, WORK, NM12 + 1 + o_work , WORK, NM13 + 1 + o_work, ref C, LL + 1 * LDC + o_c, LDC); } // * // * Test convergence // * if (Math.Abs(E[M - 1 + o_e]) <= THRESH) { E[M - 1 + o_e] = ZERO; } // * } else { // * // * Chase bulge from bottom to top // * Save cosines and sines for later singular vector updates // * CS = ONE; OLDCS = ONE; for (I = M; I >= LL + 1; I += -1) { this._dlartg.Run(D[I + o_d] * CS, E[I - 1 + o_e], ref CS, ref SN, ref R); if (I < M) { E[I + o_e] = OLDSN * R; } this._dlartg.Run(OLDCS * R, D[I - 1 + o_d] * SN, ref OLDCS, ref OLDSN, ref D[I + o_d]); WORK[I - LL + o_work] = CS; WORK[I - LL + NM1 + o_work] = -SN; WORK[I - LL + NM12 + o_work] = OLDCS; WORK[I - LL + NM13 + o_work] = -OLDSN; } H = D[LL + o_d] * CS; D[LL + o_d] = H * OLDCS; E[LL + o_e] = H * OLDSN; // * // * Update singular vectors // * if (NCVT > 0) { this._dlasr.Run("L", "V", "B", M - LL + 1, NCVT, WORK, NM12 + 1 + o_work , WORK, NM13 + 1 + o_work, ref VT, LL + 1 * LDVT + o_vt, LDVT); } if (NRU > 0) { this._dlasr.Run("R", "V", "B", NRU, M - LL + 1, WORK, 1 + o_work , WORK, N + o_work, ref U, 1 + LL * LDU + o_u, LDU); } if (NCC > 0) { this._dlasr.Run("L", "V", "B", M - LL + 1, NCC, WORK, 1 + o_work , WORK, N + o_work, ref C, LL + 1 * LDC + o_c, LDC); } // * // * Test convergence // * if (Math.Abs(E[LL + o_e]) <= THRESH) { E[LL + o_e] = ZERO; } } } else { // * // * Use nonzero shift // * if (IDIR == 1) { // * // * Chase bulge from top to bottom // * Save cosines and sines for later singular vector updates // * F = (Math.Abs(D[LL + o_d]) - SHIFT) * (FortranLib.Sign(ONE, D[LL + o_d]) + SHIFT / D[LL + o_d]); G = E[LL + o_e]; for (I = LL; I <= M - 1; I++) { this._dlartg.Run(F, G, ref COSR, ref SINR, ref R); if (I > LL) { E[I - 1 + o_e] = R; } F = COSR * D[I + o_d] + SINR * E[I + o_e]; E[I + o_e] = COSR * E[I + o_e] - SINR * D[I + o_d]; G = SINR * D[I + 1 + o_d]; D[I + 1 + o_d] *= COSR; this._dlartg.Run(F, G, ref COSL, ref SINL, ref R); D[I + o_d] = R; F = COSL * E[I + o_e] + SINL * D[I + 1 + o_d]; D[I + 1 + o_d] = COSL * D[I + 1 + o_d] - SINL * E[I + o_e]; if (I < M - 1) { G = SINL * E[I + 1 + o_e]; E[I + 1 + o_e] *= COSL; } WORK[I - LL + 1 + o_work] = COSR; WORK[I - LL + 1 + NM1 + o_work] = SINR; WORK[I - LL + 1 + NM12 + o_work] = COSL; WORK[I - LL + 1 + NM13 + o_work] = SINL; } E[M - 1 + o_e] = F; // * // * Update singular vectors // * if (NCVT > 0) { this._dlasr.Run("L", "V", "F", M - LL + 1, NCVT, WORK, 1 + o_work , WORK, N + o_work, ref VT, LL + 1 * LDVT + o_vt, LDVT); } if (NRU > 0) { this._dlasr.Run("R", "V", "F", NRU, M - LL + 1, WORK, NM12 + 1 + o_work , WORK, NM13 + 1 + o_work, ref U, 1 + LL * LDU + o_u, LDU); } if (NCC > 0) { this._dlasr.Run("L", "V", "F", M - LL + 1, NCC, WORK, NM12 + 1 + o_work , WORK, NM13 + 1 + o_work, ref C, LL + 1 * LDC + o_c, LDC); } // * // * Test convergence // * if (Math.Abs(E[M - 1 + o_e]) <= THRESH) { E[M - 1 + o_e] = ZERO; } // * } else { // * // * Chase bulge from bottom to top // * Save cosines and sines for later singular vector updates // * F = (Math.Abs(D[M + o_d]) - SHIFT) * (FortranLib.Sign(ONE, D[M + o_d]) + SHIFT / D[M + o_d]); G = E[M - 1 + o_e]; for (I = M; I >= LL + 1; I += -1) { this._dlartg.Run(F, G, ref COSR, ref SINR, ref R); if (I < M) { E[I + o_e] = R; } F = COSR * D[I + o_d] + SINR * E[I - 1 + o_e]; E[I - 1 + o_e] = COSR * E[I - 1 + o_e] - SINR * D[I + o_d]; G = SINR * D[I - 1 + o_d]; D[I - 1 + o_d] *= COSR; this._dlartg.Run(F, G, ref COSL, ref SINL, ref R); D[I + o_d] = R; F = COSL * E[I - 1 + o_e] + SINL * D[I - 1 + o_d]; D[I - 1 + o_d] = COSL * D[I - 1 + o_d] - SINL * E[I - 1 + o_e]; if (I > LL + 1) { G = SINL * E[I - 2 + o_e]; E[I - 2 + o_e] *= COSL; } WORK[I - LL + o_work] = COSR; WORK[I - LL + NM1 + o_work] = -SINR; WORK[I - LL + NM12 + o_work] = COSL; WORK[I - LL + NM13 + o_work] = -SINL; } E[LL + o_e] = F; // * // * Test convergence // * if (Math.Abs(E[LL + o_e]) <= THRESH) { E[LL + o_e] = ZERO; } // * // * Update singular vectors if desired // * if (NCVT > 0) { this._dlasr.Run("L", "V", "B", M - LL + 1, NCVT, WORK, NM12 + 1 + o_work , WORK, NM13 + 1 + o_work, ref VT, LL + 1 * LDVT + o_vt, LDVT); } if (NRU > 0) { this._dlasr.Run("R", "V", "B", NRU, M - LL + 1, WORK, 1 + o_work , WORK, N + o_work, ref U, 1 + LL * LDU + o_u, LDU); } if (NCC > 0) { this._dlasr.Run("L", "V", "B", M - LL + 1, NCC, WORK, 1 + o_work , WORK, N + o_work, ref C, LL + 1 * LDC + o_c, LDC); } } } // * // * QR iteration finished, go back and check convergence // * goto LABEL60; // * // * All singular values converged, so make them positive // * LABEL160 :; for (I = 1; I <= N; I++) { if (D[I + o_d] < ZERO) { D[I + o_d] = -D[I + o_d]; // * // * Change sign of singular vectors, if desired // * if (NCVT > 0) { this._dscal.Run(NCVT, NEGONE, ref VT, I + 1 * LDVT + o_vt, LDVT); } } } // * // * Sort the singular values into decreasing order (insertion sort on // * singular values, but only one transposition per singular vector) // * for (I = 1; I <= N - 1; I++) { // * // * Scan for smallest D(I) // * ISUB = 1; SMIN = D[1 + o_d]; for (J = 2; J <= N + 1 - I; J++) { if (D[J + o_d] <= SMIN) { ISUB = J; SMIN = D[J + o_d]; } } if (ISUB != N + 1 - I) { // * // * Swap singular values and vectors // * D[ISUB + o_d] = D[N + 1 - I + o_d]; D[N + 1 - I + o_d] = SMIN; if (NCVT > 0) { this._dswap.Run(NCVT, ref VT, ISUB + 1 * LDVT + o_vt, LDVT, ref VT, N + 1 - I + 1 * LDVT + o_vt, LDVT); } if (NRU > 0) { this._dswap.Run(NRU, ref U, 1 + ISUB * LDU + o_u, 1, ref U, 1 + (N + 1 - I) * LDU + o_u, 1); } if (NCC > 0) { this._dswap.Run(NCC, ref C, ISUB + 1 * LDC + o_c, LDC, ref C, N + 1 - I + 1 * LDC + o_c, LDC); } } } goto LABEL220; // * // * Maximum number of iterations exceeded, failure to converge // * LABEL200 :; INFO = 0; for (I = 1; I <= N - 1; I++) { if (E[I + o_e] != ZERO) { INFO += 1; } } LABEL220 :; return; // * // * End of DBDSQR // * #endregion }
/// <summary> /// Purpose /// ======= /// /// DLACON estimates the 1-norm of a square, real matrix A. /// Reverse communication is used for evaluating matrix-vector products. /// ///</summary> /// <param name="N"> /// (input) INTEGER /// The order of the matrix. N .GE. 1. ///</param> /// <param name="V"> /// (workspace) DOUBLE PRECISION array, dimension (N) /// On the final return, V = A*W, where EST = norm(V)/norm(W) /// (W is not returned). ///</param> /// <param name="X"> /// (input/output) DOUBLE PRECISION array, dimension (N) /// On an intermediate return, X should be overwritten by /// A * X, if KASE=1, /// A' * X, if KASE=2, /// and DLACON must be re-called with all the other parameters /// unchanged. ///</param> /// <param name="ISGN"> /// (workspace) INTEGER array, dimension (N) ///</param> /// <param name="EST"> /// (output) DOUBLE PRECISION /// An estimate (a lower bound) for norm(A). ///</param> /// <param name="KASE"> /// (input/output) INTEGER /// On the initial call to DLACON, KASE should be 0. /// On an intermediate return, KASE will be 1 or 2, indicating /// whether X should be overwritten by A * X or A' * X. /// On the final return from DLACON, KASE will again be 0. ///</param> public void Run(int N, ref double[] V, int offset_v, ref double[] X, int offset_x, ref int[] ISGN, int offset_isgn, ref double EST, ref int KASE) { #region Array Index Correction int o_v = -1 + offset_v; int o_x = -1 + offset_x; int o_isgn = -1 + offset_isgn; #endregion #region Prolog // * // * -- LAPACK auxiliary routine (version 3.0) -- // * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., // * Courant Institute, Argonne National Lab, and Rice University // * February 29, 1992 // * // * .. Scalar Arguments .. // * .. // * .. Array Arguments .. // * .. // * // * Purpose // * ======= // * // * DLACON estimates the 1-norm of a square, real matrix A. // * Reverse communication is used for evaluating matrix-vector products. // * // * Arguments // * ========= // * // * N (input) INTEGER // * The order of the matrix. N >= 1. // * // * V (workspace) DOUBLE PRECISION array, dimension (N) // * On the final return, V = A*W, where EST = norm(V)/norm(W) // * (W is not returned). // * // * X (input/output) DOUBLE PRECISION array, dimension (N) // * On an intermediate return, X should be overwritten by // * A * X, if KASE=1, // * A' * X, if KASE=2, // * and DLACON must be re-called with all the other parameters // * unchanged. // * // * ISGN (workspace) INTEGER array, dimension (N) // * // * EST (output) DOUBLE PRECISION // * An estimate (a lower bound) for norm(A). // * // * KASE (input/output) INTEGER // * On the initial call to DLACON, KASE should be 0. // * On an intermediate return, KASE will be 1 or 2, indicating // * whether X should be overwritten by A * X or A' * X. // * On the final return from DLACON, KASE will again be 0. // * // * Further Details // * ======= ======= // * // * Contributed by Nick Higham, University of Manchester. // * Originally named SONEST, dated March 16, 1988. // * // * Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of // * a real or complex matrix, with applications to condition estimation", // * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. // * // * ===================================================================== // * // * .. Parameters .. // * .. // * .. Local Scalars .. // * .. // * .. External Functions .. // * .. // * .. External Subroutines .. // * .. // * .. Intrinsic Functions .. // INTRINSIC ABS, DBLE, NINT, SIGN; // * .. // * .. Save statement .. // * .. // * .. Executable Statements .. // * #endregion #region Body if (KASE == 0) { for (I = 1; I <= N; I++) { X[I + o_x] = ONE / Convert.ToDouble(N); } KASE = 1; JUMP = 1; return; } // * switch (JUMP) { case 1: goto LABEL20; case 2: goto LABEL40; case 3: goto LABEL70; case 4: goto LABEL110; case 5: goto LABEL140; } // * // * ................ ENTRY (JUMP = 1) // * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. // * LABEL20 :; if (N == 1) { V[1 + o_v] = X[1 + o_x]; EST = Math.Abs(V[1 + o_v]); // * ... QUIT goto LABEL150; } EST = this._dasum.Run(N, X, offset_x, 1); // * for (I = 1; I <= N; I++) { X[I + o_x] = FortranLib.Sign(ONE, X[I + o_x]); ISGN[I + o_isgn] = (int)Math.Round(X[I + o_x]); } KASE = 2; JUMP = 2; return; // * // * ................ ENTRY (JUMP = 2) // * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. // * LABEL40 :; J = this._idamax.Run(N, X, offset_x, 1); ITER = 2; // * // * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. // * LABEL50 :; for (I = 1; I <= N; I++) { X[I + o_x] = ZERO; } X[J + o_x] = ONE; KASE = 1; JUMP = 3; return; // * // * ................ ENTRY (JUMP = 3) // * X HAS BEEN OVERWRITTEN BY A*X. // * LABEL70 :; this._dcopy.Run(N, X, offset_x, 1, ref V, offset_v, 1); ESTOLD = EST; EST = this._dasum.Run(N, V, offset_v, 1); for (I = 1; I <= N; I++) { if (Math.Round(FortranLib.Sign(ONE, X[I + o_x])) != ISGN[I + o_isgn]) { goto LABEL90; } } // * REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. goto LABEL120; // * LABEL90 :; // * TEST FOR CYCLING. if (EST <= ESTOLD) { goto LABEL120; } // * for (I = 1; I <= N; I++) { X[I + o_x] = FortranLib.Sign(ONE, X[I + o_x]); ISGN[I + o_isgn] = (int)Math.Round(X[I + o_x]); } KASE = 2; JUMP = 4; return; // * // * ................ ENTRY (JUMP = 4) // * X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. // * LABEL110 :; JLAST = J; J = this._idamax.Run(N, X, offset_x, 1); if ((X[JLAST + o_x] != Math.Abs(X[J + o_x])) && (ITER < ITMAX)) { ITER += 1; goto LABEL50; } // * // * ITERATION COMPLETE. FINAL STAGE. // * LABEL120 :; ALTSGN = ONE; for (I = 1; I <= N; I++) { X[I + o_x] = ALTSGN * (ONE + Convert.ToDouble(I - 1) / Convert.ToDouble(N - 1)); ALTSGN = -ALTSGN; } KASE = 1; JUMP = 5; return; // * // * ................ ENTRY (JUMP = 5) // * X HAS BEEN OVERWRITTEN BY A*X. // * LABEL140 :; TEMP = TWO * (this._dasum.Run(N, X, offset_x, 1) / Convert.ToDouble(3 * N)); if (TEMP > EST) { this._dcopy.Run(N, X, offset_x, 1, ref V, offset_v, 1); EST = TEMP; } // * LABEL150 :; KASE = 0; return; // * // * End of DLACON // * #endregion }
/// <summary> /// Purpose /// ======= /// /// DLASD3 finds all the square roots of the roots of the secular /// equation, as defined by the values in D and Z. It makes the /// appropriate calls to DLASD4 and then updates the singular /// vectors by matrix multiplication. /// /// This code makes very mild assumptions about floating point /// arithmetic. It will work on machines with a guard digit in /// add/subtract, or on those binary machines without guard digits /// which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. /// It could conceivably fail on hexadecimal or decimal machines /// without guard digits, but we know of none. /// /// DLASD3 is called from DLASD1. /// ///</summary> /// <param name="NL"> /// (input) INTEGER /// The row dimension of the upper block. NL .GE. 1. ///</param> /// <param name="NR"> /// (input) INTEGER /// The row dimension of the lower block. NR .GE. 1. ///</param> /// <param name="SQRE"> /// (input) INTEGER /// = 0: the lower block is an NR-by-NR square matrix. /// = 1: the lower block is an NR-by-(NR+1) rectangular matrix. /// /// The bidiagonal matrix has N = NL + NR + 1 rows and /// M = N + SQRE .GE. N columns. ///</param> /// <param name="K"> /// (input) INTEGER /// The size of the secular equation, 1 =.LT. K = .LT. N. ///</param> /// <param name="D"> /// (output) DOUBLE PRECISION array, dimension(K) /// On exit the square roots of the roots of the secular equation, /// in ascending order. ///</param> /// <param name="Q"> /// (workspace) DOUBLE PRECISION array, /// dimension at least (LDQ,K). ///</param> /// <param name="LDQ"> /// (input) INTEGER /// The leading dimension of the array Q. LDQ .GE. K. ///</param> /// <param name="DSIGMA"> /// (input) DOUBLE PRECISION array, dimension(K) /// The first K elements of this array contain the old roots /// of the deflated updating problem. These are the poles /// of the secular equation. ///</param> /// <param name="U"> /// (output) DOUBLE PRECISION array, dimension (LDU, N) /// The last N - K columns of this matrix contain the deflated /// left singular vectors. ///</param> /// <param name="LDU"> /// (input) INTEGER /// The leading dimension of the array U. LDU .GE. N. ///</param> /// <param name="U2"> /// (input/output) DOUBLE PRECISION array, dimension (LDU2, N) /// The first K columns of this matrix contain the non-deflated /// left singular vectors for the split problem. ///</param> /// <param name="LDU2"> /// (input) INTEGER /// The leading dimension of the array U2. LDU2 .GE. N. ///</param> /// <param name="VT"> /// (output) DOUBLE PRECISION array, dimension (LDVT, M) /// The last M - K columns of VT' contain the deflated /// right singular vectors. ///</param> /// <param name="LDVT"> /// (input) INTEGER /// The leading dimension of the array VT. LDVT .GE. N. ///</param> /// <param name="VT2"> /// (input/output) DOUBLE PRECISION array, dimension (LDVT2, N) /// The first K columns of VT2' contain the non-deflated /// right singular vectors for the split problem. ///</param> /// <param name="LDVT2"> /// (input) INTEGER /// The leading dimension of the array VT2. LDVT2 .GE. N. ///</param> /// <param name="IDXC"> /// (input) INTEGER array, dimension ( N ) /// The permutation used to arrange the columns of U (and rows of /// VT) into three groups: the first group contains non-zero /// entries only at and above (or before) NL +1; the second /// contains non-zero entries only at and below (or after) NL+2; /// and the third is dense. The first column of U and the row of /// VT are treated separately, however. /// /// The rows of the singular vectors found by DLASD4 /// must be likewise permuted before the matrix multiplies can /// take place. ///</param> /// <param name="CTOT"> /// (input) INTEGER array, dimension ( 4 ) /// A count of the total number of the various types of columns /// in U (or rows in VT), as described in IDXC. The fourth column /// type is any column which has been deflated. ///</param> /// <param name="Z"> /// (input) DOUBLE PRECISION array, dimension (K) /// The first K elements of this array contain the components /// of the deflation-adjusted updating row vector. ///</param> /// <param name="INFO"> /// (output) INTEGER /// = 0: successful exit. /// .LT. 0: if INFO = -i, the i-th argument had an illegal value. /// .GT. 0: if INFO = 1, an singular value did not converge ///</param> public void Run(int NL, int NR, int SQRE, int K, ref double[] D, int offset_d, ref double[] Q, int offset_q , int LDQ, ref double[] DSIGMA, int offset_dsigma, ref double[] U, int offset_u, int LDU, double[] U2, int offset_u2, int LDU2 , ref double[] VT, int offset_vt, int LDVT, ref double[] VT2, int offset_vt2, int LDVT2, int[] IDXC, int offset_idxc, int[] CTOT, int offset_ctot , ref double[] Z, int offset_z, ref int INFO) { #region Variables int CTEMP = 0; int I = 0; int J = 0; int JC = 0; int KTEMP = 0; int M = 0; int N = 0; int NLP1 = 0; int NLP2 = 0; int NRP1 = 0; double RHO = 0; double TEMP = 0; #endregion #region Implicit Variables int U_1 = 0; int U2_1 = 0; int U_K = 0; int VT_K = 0; int VT_I = 0; int U_I = 0; int Q_I = 0; int Q_1 = 0; int Q_KTEMP = 0; #endregion #region Array Index Correction int o_d = -1 + offset_d; int o_q = -1 - LDQ + offset_q; int o_dsigma = -1 + offset_dsigma; int o_u = -1 - LDU + offset_u; int o_u2 = -1 - LDU2 + offset_u2; int o_vt = -1 - LDVT + offset_vt; int o_vt2 = -1 - LDVT2 + offset_vt2; int o_idxc = -1 + offset_idxc; int o_ctot = -1 + offset_ctot; int o_z = -1 + offset_z; #endregion #region Prolog // * // * -- LAPACK auxiliary routine (version 3.1) -- // * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. // * November 2006 // * // * .. Scalar Arguments .. // * .. // * .. Array Arguments .. // * .. // * // * Purpose // * ======= // * // * DLASD3 finds all the square roots of the roots of the secular // * equation, as defined by the values in D and Z. It makes the // * appropriate calls to DLASD4 and then updates the singular // * vectors by matrix multiplication. // * // * This code makes very mild assumptions about floating point // * arithmetic. It will work on machines with a guard digit in // * add/subtract, or on those binary machines without guard digits // * which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. // * It could conceivably fail on hexadecimal or decimal machines // * without guard digits, but we know of none. // * // * DLASD3 is called from DLASD1. // * // * Arguments // * ========= // * // * NL (input) INTEGER // * The row dimension of the upper block. NL >= 1. // * // * NR (input) INTEGER // * The row dimension of the lower block. NR >= 1. // * // * SQRE (input) INTEGER // * = 0: the lower block is an NR-by-NR square matrix. // * = 1: the lower block is an NR-by-(NR+1) rectangular matrix. // * // * The bidiagonal matrix has N = NL + NR + 1 rows and // * M = N + SQRE >= N columns. // * // * K (input) INTEGER // * The size of the secular equation, 1 =< K = < N. // * // * D (output) DOUBLE PRECISION array, dimension(K) // * On exit the square roots of the roots of the secular equation, // * in ascending order. // * // * Q (workspace) DOUBLE PRECISION array, // * dimension at least (LDQ,K). // * // * LDQ (input) INTEGER // * The leading dimension of the array Q. LDQ >= K. // * // * DSIGMA (input) DOUBLE PRECISION array, dimension(K) // * The first K elements of this array contain the old roots // * of the deflated updating problem. These are the poles // * of the secular equation. // * // * U (output) DOUBLE PRECISION array, dimension (LDU, N) // * The last N - K columns of this matrix contain the deflated // * left singular vectors. // * // * LDU (input) INTEGER // * The leading dimension of the array U. LDU >= N. // * // * U2 (input/output) DOUBLE PRECISION array, dimension (LDU2, N) // * The first K columns of this matrix contain the non-deflated // * left singular vectors for the split problem. // * // * LDU2 (input) INTEGER // * The leading dimension of the array U2. LDU2 >= N. // * // * VT (output) DOUBLE PRECISION array, dimension (LDVT, M) // * The last M - K columns of VT' contain the deflated // * right singular vectors. // * // * LDVT (input) INTEGER // * The leading dimension of the array VT. LDVT >= N. // * // * VT2 (input/output) DOUBLE PRECISION array, dimension (LDVT2, N) // * The first K columns of VT2' contain the non-deflated // * right singular vectors for the split problem. // * // * LDVT2 (input) INTEGER // * The leading dimension of the array VT2. LDVT2 >= N. // * // * IDXC (input) INTEGER array, dimension ( N ) // * The permutation used to arrange the columns of U (and rows of // * VT) into three groups: the first group contains non-zero // * entries only at and above (or before) NL +1; the second // * contains non-zero entries only at and below (or after) NL+2; // * and the third is dense. The first column of U and the row of // * VT are treated separately, however. // * // * The rows of the singular vectors found by DLASD4 // * must be likewise permuted before the matrix multiplies can // * take place. // * // * CTOT (input) INTEGER array, dimension ( 4 ) // * A count of the total number of the various types of columns // * in U (or rows in VT), as described in IDXC. The fourth column // * type is any column which has been deflated. // * // * Z (input) DOUBLE PRECISION array, dimension (K) // * The first K elements of this array contain the components // * of the deflation-adjusted updating row vector. // * // * INFO (output) INTEGER // * = 0: successful exit. // * < 0: if INFO = -i, the i-th argument had an illegal value. // * > 0: if INFO = 1, an singular value did not converge // * // * Further Details // * =============== // * // * Based on contributions by // * Ming Gu and Huan Ren, Computer Science Division, University of // * California at Berkeley, USA // * // * ===================================================================== // * // * .. Parameters .. // * .. // * .. Local Scalars .. // * .. // * .. External Functions .. // * .. // * .. External Subroutines .. // * .. // * .. Intrinsic Functions .. // INTRINSIC ABS, SIGN, SQRT; // * .. // * .. Executable Statements .. // * // * Test the input parameters. // * #endregion #region Body INFO = 0; // * if (NL < 1) { INFO = -1; } else { if (NR < 1) { INFO = -2; } else { if ((SQRE != 1) && (SQRE != 0)) { INFO = -3; } } } // * N = NL + NR + 1; M = N + SQRE; NLP1 = NL + 1; NLP2 = NL + 2; // * if ((K < 1) || (K > N)) { INFO = -4; } else { if (LDQ < K) { INFO = -7; } else { if (LDU < N) { INFO = -10; } else { if (LDU2 < N) { INFO = -12; } else { if (LDVT < M) { INFO = -14; } else { if (LDVT2 < M) { INFO = -16; } } } } } } if (INFO != 0) { this._xerbla.Run("DLASD3", -INFO); return; } // * // * Quick return if possible // * if (K == 1) { D[1 + o_d] = Math.Abs(Z[1 + o_z]); this._dcopy.Run(M, VT2, 1 + 1 * LDVT2 + o_vt2, LDVT2, ref VT, 1 + 1 * LDVT + o_vt, LDVT); if (Z[1 + o_z] > ZERO) { this._dcopy.Run(N, U2, 1 + 1 * LDU2 + o_u2, 1, ref U, 1 + 1 * LDU + o_u, 1); } else { U_1 = 1 * LDU + o_u; U2_1 = 1 * LDU2 + o_u2; for (I = 1; I <= N; I++) { U[I + U_1] = -U2[I + U2_1]; } } return; } // * // * Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can // * be computed with high relative accuracy (barring over/underflow). // * This is a problem on machines without a guard digit in // * add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). // * The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), // * which on any of these machines zeros out the bottommost // * bit of DSIGMA(I) if it is 1; this makes the subsequent // * subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation // * occurs. On binary machines with a guard digit (almost all // * machines) it does not change DSIGMA(I) at all. On hexadecimal // * and decimal machines with a guard digit, it slightly // * changes the bottommost bits of DSIGMA(I). It does not account // * for hexadecimal or decimal machines without guard digits // * (we know of none). We use a subroutine call to compute // * 2*DSIGMA(I) to prevent optimizing compilers from eliminating // * this code. // * for (I = 1; I <= K; I++) { DSIGMA[I + o_dsigma] = this._dlamc3.Run(DSIGMA[I + o_dsigma], DSIGMA[I + o_dsigma]) - DSIGMA[I + o_dsigma]; } // * // * Keep a copy of Z. // * this._dcopy.Run(K, Z, offset_z, 1, ref Q, offset_q, 1); // * // * Normalize Z. // * RHO = this._dnrm2.Run(K, Z, offset_z, 1); this._dlascl.Run("G", 0, 0, RHO, ONE, K , 1, ref Z, offset_z, K, ref INFO); RHO *= RHO; // * // * Find the new singular values. // * for (J = 1; J <= K; J++) { this._dlasd4.Run(K, J, DSIGMA, offset_dsigma, Z, offset_z, ref U, 1 + J * LDU + o_u, RHO , ref D[J + o_d], ref VT, 1 + J * LDVT + o_vt, ref INFO); // * // * If the zero finder fails, the computation is terminated. // * if (INFO != 0) { return; } } // * // * Compute updated Z. // * U_K = K * LDU + o_u; VT_K = K * LDVT + o_vt; for (I = 1; I <= K; I++) { Z[I + o_z] = U[I + U_K] * VT[I + VT_K]; for (J = 1; J <= I - 1; J++) { Z[I + o_z] = Z[I + o_z] * (U[I + J * LDU + o_u] * VT[I + J * LDVT + o_vt] / (DSIGMA[I + o_dsigma] - DSIGMA[J + o_dsigma]) / (DSIGMA[I + o_dsigma] + DSIGMA[J + o_dsigma])); } for (J = I; J <= K - 1; J++) { Z[I + o_z] = Z[I + o_z] * (U[I + J * LDU + o_u] * VT[I + J * LDVT + o_vt] / (DSIGMA[I + o_dsigma] - DSIGMA[J + 1 + o_dsigma]) / (DSIGMA[I + o_dsigma] + DSIGMA[J + 1 + o_dsigma])); } Z[I + o_z] = FortranLib.Sign(Math.Sqrt(Math.Abs(Z[I + o_z])), Q[I + 1 * LDQ + o_q]); } // * // * Compute left singular vectors of the modified diagonal matrix, // * and store related information for the right singular vectors. // * for (I = 1; I <= K; I++) { VT[1 + I * LDVT + o_vt] = Z[1 + o_z] / U[1 + I * LDU + o_u] / VT[1 + I * LDVT + o_vt]; U[1 + I * LDU + o_u] = NEGONE; VT_I = I * LDVT + o_vt; U_I = I * LDU + o_u; for (J = 2; J <= K; J++) { VT[J + VT_I] = Z[J + o_z] / U[J + U_I] / VT[J + VT_I]; U[J + U_I] = DSIGMA[J + o_dsigma] * VT[J + VT_I]; } TEMP = this._dnrm2.Run(K, U, 1 + I * LDU + o_u, 1); Q[1 + I * LDQ + o_q] = U[1 + I * LDU + o_u] / TEMP; Q_I = I * LDQ + o_q; for (J = 2; J <= K; J++) { JC = IDXC[J + o_idxc]; Q[J + Q_I] = U[JC + I * LDU + o_u] / TEMP; } } // * // * Update the left singular vector matrix. // * if (K == 2) { this._dgemm.Run("N", "N", N, K, K, ONE , U2, offset_u2, LDU2, Q, offset_q, LDQ, ZERO, ref U, offset_u , LDU); goto LABEL100; } if (CTOT[1 + o_ctot] > 0) { this._dgemm.Run("N", "N", NL, K, CTOT[1 + o_ctot], ONE , U2, 1 + 2 * LDU2 + o_u2, LDU2, Q, 2 + 1 * LDQ + o_q, LDQ, ZERO, ref U, 1 + 1 * LDU + o_u , LDU); if (CTOT[3 + o_ctot] > 0) { KTEMP = 2 + CTOT[1 + o_ctot] + CTOT[2 + o_ctot]; this._dgemm.Run("N", "N", NL, K, CTOT[3 + o_ctot], ONE , U2, 1 + KTEMP * LDU2 + o_u2, LDU2, Q, KTEMP + 1 * LDQ + o_q, LDQ, ONE, ref U, 1 + 1 * LDU + o_u , LDU); } } else { if (CTOT[3 + o_ctot] > 0) { KTEMP = 2 + CTOT[1 + o_ctot] + CTOT[2 + o_ctot]; this._dgemm.Run("N", "N", NL, K, CTOT[3 + o_ctot], ONE , U2, 1 + KTEMP * LDU2 + o_u2, LDU2, Q, KTEMP + 1 * LDQ + o_q, LDQ, ZERO, ref U, 1 + 1 * LDU + o_u , LDU); } else { this._dlacpy.Run("F", NL, K, U2, offset_u2, LDU2, ref U, offset_u , LDU); } } this._dcopy.Run(K, Q, 1 + 1 * LDQ + o_q, LDQ, ref U, NLP1 + 1 * LDU + o_u, LDU); KTEMP = 2 + CTOT[1 + o_ctot]; CTEMP = CTOT[2 + o_ctot] + CTOT[3 + o_ctot]; this._dgemm.Run("N", "N", NR, K, CTEMP, ONE , U2, NLP2 + KTEMP * LDU2 + o_u2, LDU2, Q, KTEMP + 1 * LDQ + o_q, LDQ, ZERO, ref U, NLP2 + 1 * LDU + o_u , LDU); // * // * Generate the right singular vectors. // * LABEL100 :; Q_1 = 1 * LDQ + o_q; for (I = 1; I <= K; I++) { TEMP = this._dnrm2.Run(K, VT, 1 + I * LDVT + o_vt, 1); Q[I + Q_1] = VT[1 + I * LDVT + o_vt] / TEMP; for (J = 2; J <= K; J++) { JC = IDXC[J + o_idxc]; Q[I + J * LDQ + o_q] = VT[JC + I * LDVT + o_vt] / TEMP; } } // * // * Update the right singular vector matrix. // * if (K == 2) { this._dgemm.Run("N", "N", K, M, K, ONE , Q, offset_q, LDQ, VT2, offset_vt2, LDVT2, ZERO, ref VT, offset_vt , LDVT); return; } KTEMP = 1 + CTOT[1 + o_ctot]; this._dgemm.Run("N", "N", K, NLP1, KTEMP, ONE , Q, 1 + 1 * LDQ + o_q, LDQ, VT2, 1 + 1 * LDVT2 + o_vt2, LDVT2, ZERO, ref VT, 1 + 1 * LDVT + o_vt , LDVT); KTEMP = 2 + CTOT[1 + o_ctot] + CTOT[2 + o_ctot]; if (KTEMP <= LDVT2) { this._dgemm.Run("N", "N", K, NLP1, CTOT[3 + o_ctot], ONE , Q, 1 + KTEMP * LDQ + o_q, LDQ, VT2, KTEMP + 1 * LDVT2 + o_vt2, LDVT2, ONE, ref VT, 1 + 1 * LDVT + o_vt , LDVT); } // * KTEMP = CTOT[1 + o_ctot] + 1; NRP1 = NR + SQRE; if (KTEMP > 1) { Q_KTEMP = KTEMP * LDQ + o_q; Q_1 = 1 * LDQ + o_q; for (I = 1; I <= K; I++) { Q[I + Q_KTEMP] = Q[I + Q_1]; } for (I = NLP2; I <= M; I++) { VT2[KTEMP + I * LDVT2 + o_vt2] = VT2[1 + I * LDVT2 + o_vt2]; } } CTEMP = 1 + CTOT[2 + o_ctot] + CTOT[3 + o_ctot]; this._dgemm.Run("N", "N", K, NRP1, CTEMP, ONE , Q, 1 + KTEMP * LDQ + o_q, LDQ, VT2, KTEMP + NLP2 * LDVT2 + o_vt2, LDVT2, ZERO, ref VT, 1 + NLP2 * LDVT + o_vt , LDVT); // * return; // * // * End of DLASD3 // * #endregion }
/// <summary> /// Purpose /// ======= /// /// DLAED3 finds the roots of the secular equation, as defined by the /// values in D, W, and RHO, between 1 and K. It makes the /// appropriate calls to DLAED4 and then updates the eigenvectors by /// multiplying the matrix of eigenvectors of the pair of eigensystems /// being combined by the matrix of eigenvectors of the K-by-K system /// which is solved here. /// /// This code makes very mild assumptions about floating point /// arithmetic. It will work on machines with a guard digit in /// add/subtract, or on those binary machines without guard digits /// which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. /// It could conceivably fail on hexadecimal or decimal machines /// without guard digits, but we know of none. /// ///</summary> /// <param name="K"> /// (input) INTEGER /// The number of terms in the rational function to be solved by /// DLAED4. K .GE. 0. ///</param> /// <param name="N"> /// (input) INTEGER /// The number of rows and columns in the Q matrix. /// N .GE. K (deflation may result in N.GT.K). ///</param> /// <param name="N1"> /// (input) INTEGER /// The location of the last eigenvalue in the leading submatrix. /// min(1,N) .LE. N1 .LE. N/2. ///</param> /// <param name="D"> /// (output) DOUBLE PRECISION array, dimension (N) /// D(I) contains the updated eigenvalues for /// 1 .LE. I .LE. K. ///</param> /// <param name="Q"> /// (output) DOUBLE PRECISION array, dimension (LDQ,N) /// Initially the first K columns are used as workspace. /// On output the columns 1 to K contain /// the updated eigenvectors. ///</param> /// <param name="LDQ"> /// (input) INTEGER /// The leading dimension of the array Q. LDQ .GE. max(1,N). ///</param> /// <param name="RHO"> /// (input) DOUBLE PRECISION /// The value of the parameter in the rank one update equation. /// RHO .GE. 0 required. ///</param> /// <param name="DLAMDA"> /// (input/output) DOUBLE PRECISION array, dimension (K) /// The first K elements of this array contain the old roots /// of the deflated updating problem. These are the poles /// of the secular equation. May be changed on output by /// having lowest order bit set to zero on Cray X-MP, Cray Y-MP, /// Cray-2, or Cray C-90, as described above. ///</param> /// <param name="Q2"> /// (input) DOUBLE PRECISION array, dimension (LDQ2, N) /// The first K columns of this matrix contain the non-deflated /// eigenvectors for the split problem. ///</param> /// <param name="INDX"> /// (input) INTEGER array, dimension (N) /// The permutation used to arrange the columns of the deflated /// Q matrix into three groups (see DLAED2). /// The rows of the eigenvectors found by DLAED4 must be likewise /// permuted before the matrix multiply can take place. ///</param> /// <param name="CTOT"> /// (input) INTEGER array, dimension (4) /// A count of the total number of the various types of columns /// in Q, as described in INDX. The fourth column type is any /// column which has been deflated. ///</param> /// <param name="W"> /// (input/output) DOUBLE PRECISION array, dimension (K) /// The first K elements of this array contain the components /// of the deflation-adjusted updating vector. Destroyed on /// output. ///</param> /// <param name="S"> /// (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K /// Will contain the eigenvectors of the repaired matrix which /// will be multiplied by the previously accumulated eigenvectors /// to update the system. ///</param> /// <param name="INFO"> /// (output) INTEGER /// = 0: successful exit. /// .LT. 0: if INFO = -i, the i-th argument had an illegal value. /// .GT. 0: if INFO = 1, an eigenvalue did not converge ///</param> public void Run(int K, int N, int N1, ref double[] D, int offset_d, ref double[] Q, int offset_q, int LDQ , double RHO, ref double[] DLAMDA, int offset_dlamda, double[] Q2, int offset_q2, int[] INDX, int offset_indx, int[] CTOT, int offset_ctot, ref double[] W, int offset_w , ref double[] S, int offset_s, ref int INFO) { #region Variables int I = 0; int II = 0; int IQ2 = 0; int J = 0; int N12 = 0; int N2 = 0; int N23 = 0; double TEMP = 0; #endregion #region Implicit Variables int Q_J = 0; #endregion #region Array Index Correction int o_d = -1 + offset_d; int o_q = -1 - LDQ + offset_q; int o_dlamda = -1 + offset_dlamda; int o_q2 = -1 + offset_q2; int o_indx = -1 + offset_indx; int o_ctot = -1 + offset_ctot; int o_w = -1 + offset_w; int o_s = -1 + offset_s; #endregion #region Prolog // * // * -- LAPACK routine (version 3.1) -- // * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. // * November 2006 // * // * .. Scalar Arguments .. // * .. // * .. Array Arguments .. // * .. // * // * Purpose // * ======= // * // * DLAED3 finds the roots of the secular equation, as defined by the // * values in D, W, and RHO, between 1 and K. It makes the // * appropriate calls to DLAED4 and then updates the eigenvectors by // * multiplying the matrix of eigenvectors of the pair of eigensystems // * being combined by the matrix of eigenvectors of the K-by-K system // * which is solved here. // * // * This code makes very mild assumptions about floating point // * arithmetic. It will work on machines with a guard digit in // * add/subtract, or on those binary machines without guard digits // * which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. // * It could conceivably fail on hexadecimal or decimal machines // * without guard digits, but we know of none. // * // * Arguments // * ========= // * // * K (input) INTEGER // * The number of terms in the rational function to be solved by // * DLAED4. K >= 0. // * // * N (input) INTEGER // * The number of rows and columns in the Q matrix. // * N >= K (deflation may result in N>K). // * // * N1 (input) INTEGER // * The location of the last eigenvalue in the leading submatrix. // * min(1,N) <= N1 <= N/2. // * // * D (output) DOUBLE PRECISION array, dimension (N) // * D(I) contains the updated eigenvalues for // * 1 <= I <= K. // * // * Q (output) DOUBLE PRECISION array, dimension (LDQ,N) // * Initially the first K columns are used as workspace. // * On output the columns 1 to K contain // * the updated eigenvectors. // * // * LDQ (input) INTEGER // * The leading dimension of the array Q. LDQ >= max(1,N). // * // * RHO (input) DOUBLE PRECISION // * The value of the parameter in the rank one update equation. // * RHO >= 0 required. // * // * DLAMDA (input/output) DOUBLE PRECISION array, dimension (K) // * The first K elements of this array contain the old roots // * of the deflated updating problem. These are the poles // * of the secular equation. May be changed on output by // * having lowest order bit set to zero on Cray X-MP, Cray Y-MP, // * Cray-2, or Cray C-90, as described above. // * // * Q2 (input) DOUBLE PRECISION array, dimension (LDQ2, N) // * The first K columns of this matrix contain the non-deflated // * eigenvectors for the split problem. // * // * INDX (input) INTEGER array, dimension (N) // * The permutation used to arrange the columns of the deflated // * Q matrix into three groups (see DLAED2). // * The rows of the eigenvectors found by DLAED4 must be likewise // * permuted before the matrix multiply can take place. // * // * CTOT (input) INTEGER array, dimension (4) // * A count of the total number of the various types of columns // * in Q, as described in INDX. The fourth column type is any // * column which has been deflated. // * // * W (input/output) DOUBLE PRECISION array, dimension (K) // * The first K elements of this array contain the components // * of the deflation-adjusted updating vector. Destroyed on // * output. // * // * S (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K // * Will contain the eigenvectors of the repaired matrix which // * will be multiplied by the previously accumulated eigenvectors // * to update the system. // * // * LDS (input) INTEGER // * The leading dimension of S. LDS >= max(1,K). // * // * INFO (output) INTEGER // * = 0: successful exit. // * < 0: if INFO = -i, the i-th argument had an illegal value. // * > 0: if INFO = 1, an eigenvalue did not converge // * // * Further Details // * =============== // * // * Based on contributions by // * Jeff Rutter, Computer Science Division, University of California // * at Berkeley, USA // * Modified by Francoise Tisseur, University of Tennessee. // * // * ===================================================================== // * // * .. Parameters .. // * .. // * .. Local Scalars .. // * .. // * .. External Functions .. // * .. // * .. External Subroutines .. // * .. // * .. Intrinsic Functions .. // INTRINSIC MAX, SIGN, SQRT; // * .. // * .. Executable Statements .. // * // * Test the input parameters. // * #endregion #region Body INFO = 0; // * if (K < 0) { INFO = -1; } else { if (N < K) { INFO = -2; } else { if (LDQ < Math.Max(1, N)) { INFO = -6; } } } if (INFO != 0) { this._xerbla.Run("DLAED3", -INFO); return; } // * // * Quick return if possible // * if (K == 0) { return; } // * // * Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can // * be computed with high relative accuracy (barring over/underflow). // * This is a problem on machines without a guard digit in // * add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). // * The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), // * which on any of these machines zeros out the bottommost // * bit of DLAMDA(I) if it is 1; this makes the subsequent // * subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation // * occurs. On binary machines with a guard digit (almost all // * machines) it does not change DLAMDA(I) at all. On hexadecimal // * and decimal machines with a guard digit, it slightly // * changes the bottommost bits of DLAMDA(I). It does not account // * for hexadecimal or decimal machines without guard digits // * (we know of none). We use a subroutine call to compute // * 2*DLAMBDA(I) to prevent optimizing compilers from eliminating // * this code. // * for (I = 1; I <= K; I++) { DLAMDA[I + o_dlamda] = this._dlamc3.Run(DLAMDA[I + o_dlamda], DLAMDA[I + o_dlamda]) - DLAMDA[I + o_dlamda]; } // * for (J = 1; J <= K; J++) { this._dlaed4.Run(K, J, DLAMDA, offset_dlamda, W, offset_w, ref Q, 1 + J * LDQ + o_q, RHO , ref D[J + o_d], ref INFO); // * // * If the zero finder fails, the computation is terminated. // * if (INFO != 0) { goto LABEL120; } } // * if (K == 1) { goto LABEL110; } if (K == 2) { for (J = 1; J <= K; J++) { W[1 + o_w] = Q[1 + J * LDQ + o_q]; W[2 + o_w] = Q[2 + J * LDQ + o_q]; II = INDX[1 + o_indx]; Q[1 + J * LDQ + o_q] = W[II + o_w]; II = INDX[2 + o_indx]; Q[2 + J * LDQ + o_q] = W[II + o_w]; } goto LABEL110; } // * // * Compute updated W. // * this._dcopy.Run(K, W, offset_w, 1, ref S, offset_s, 1); // * // * Initialize W(I) = Q(I,I) // * this._dcopy.Run(K, Q, offset_q, LDQ + 1, ref W, offset_w, 1); for (J = 1; J <= K; J++) { Q_J = J * LDQ + o_q; for (I = 1; I <= J - 1; I++) { W[I + o_w] = W[I + o_w] * (Q[I + Q_J] / (DLAMDA[I + o_dlamda] - DLAMDA[J + o_dlamda])); } Q_J = J * LDQ + o_q; for (I = J + 1; I <= K; I++) { W[I + o_w] = W[I + o_w] * (Q[I + Q_J] / (DLAMDA[I + o_dlamda] - DLAMDA[J + o_dlamda])); } } for (I = 1; I <= K; I++) { W[I + o_w] = FortranLib.Sign(Math.Sqrt(-W[I + o_w]), S[I + o_s]); } // * // * Compute eigenvectors of the modified rank-1 modification. // * for (J = 1; J <= K; J++) { Q_J = J * LDQ + o_q; for (I = 1; I <= K; I++) { S[I + o_s] = W[I + o_w] / Q[I + Q_J]; } TEMP = this._dnrm2.Run(K, S, offset_s, 1); Q_J = J * LDQ + o_q; for (I = 1; I <= K; I++) { II = INDX[I + o_indx]; Q[I + Q_J] = S[II + o_s] / TEMP; } } // * // * Compute the updated eigenvectors. // * LABEL110 :; // * N2 = N - N1; N12 = CTOT[1 + o_ctot] + CTOT[2 + o_ctot]; N23 = CTOT[2 + o_ctot] + CTOT[3 + o_ctot]; // * this._dlacpy.Run("A", N23, K, Q, CTOT[1 + o_ctot] + 1 + 1 * LDQ + o_q, LDQ, ref S, offset_s , N23); IQ2 = N1 * N12 + 1; if (N23 != 0) { this._dgemm.Run("N", "N", N2, K, N23, ONE , Q2, IQ2 + o_q2, N2, S, offset_s, N23, ZERO, ref Q, N1 + 1 + 1 * LDQ + o_q , LDQ); } else { this._dlaset.Run("A", N2, K, ZERO, ZERO, ref Q, N1 + 1 + 1 * LDQ + o_q , LDQ); } // * this._dlacpy.Run("A", N12, K, Q, offset_q, LDQ, ref S, offset_s , N12); if (N12 != 0) { this._dgemm.Run("N", "N", N1, K, N12, ONE , Q2, offset_q2, N1, S, offset_s, N12, ZERO, ref Q, offset_q , LDQ); } else { this._dlaset.Run("A", N1, K, ZERO, ZERO, ref Q, 1 + 1 * LDQ + o_q , LDQ); } // * // * LABEL120 :; return; // * // * End of DLAED3 // * #endregion }
/// <summary> /// Purpose /// ======= /// /// DGEEV computes for an N-by-N real nonsymmetric matrix A, the /// eigenvalues and, optionally, the left and/or right eigenvectors. /// /// The right eigenvector v(j) of A satisfies /// A * v(j) = lambda(j) * v(j) /// where lambda(j) is its eigenvalue. /// The left eigenvector u(j) of A satisfies /// u(j)**H * A = lambda(j) * u(j)**H /// where u(j)**H denotes the conjugate transpose of u(j). /// /// The computed eigenvectors are normalized to have Euclidean norm /// equal to 1 and largest component real. /// ///</summary> /// <param name="JOBVL"> /// (input) CHARACTER*1 /// = 'N': left eigenvectors of A are not computed; /// = 'V': left eigenvectors of A are computed. ///</param> /// <param name="JOBVR"> /// (input) CHARACTER*1 /// = 'N': right eigenvectors of A are not computed; /// = 'V': right eigenvectors of A are computed. ///</param> /// <param name="N"> /// (input) INTEGER /// The order of the matrix A. N .GE. 0. ///</param> /// <param name="A"> /// (input/output) DOUBLE PRECISION array, dimension (LDA,N) /// On entry, the N-by-N matrix A. /// On exit, A has been overwritten. ///</param> /// <param name="LDA"> /// (input) INTEGER /// The leading dimension of the array A. LDA .GE. max(1,N). ///</param> /// <param name="WR"> /// (output) DOUBLE PRECISION array, dimension (N) ///</param> /// <param name="WI"> /// (output) DOUBLE PRECISION array, dimension (N) /// WR and WI contain the real and imaginary parts, /// respectively, of the computed eigenvalues. Complex /// conjugate pairs of eigenvalues appear consecutively /// with the eigenvalue having the positive imaginary part /// first. ///</param> /// <param name="VL"> /// (output) DOUBLE PRECISION array, dimension (LDVL,N) /// If JOBVL = 'V', the left eigenvectors u(j) are stored one /// after another in the columns of VL, in the same order /// as their eigenvalues. /// If JOBVL = 'N', VL is not referenced. /// If the j-th eigenvalue is real, then u(j) = VL(:,j), /// the j-th column of VL. /// If the j-th and (j+1)-st eigenvalues form a complex /// conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and /// u(j+1) = VL(:,j) - i*VL(:,j+1). ///</param> /// <param name="LDVL"> /// (input) INTEGER /// The leading dimension of the array VL. LDVL .GE. 1; if /// JOBVL = 'V', LDVL .GE. N. ///</param> /// <param name="VR"> /// (output) DOUBLE PRECISION array, dimension (LDVR,N) /// If JOBVR = 'V', the right eigenvectors v(j) are stored one /// after another in the columns of VR, in the same order /// as their eigenvalues. /// If JOBVR = 'N', VR is not referenced. /// If the j-th eigenvalue is real, then v(j) = VR(:,j), /// the j-th column of VR. /// If the j-th and (j+1)-st eigenvalues form a complex /// conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and /// v(j+1) = VR(:,j) - i*VR(:,j+1). ///</param> /// <param name="LDVR"> /// (input) INTEGER /// The leading dimension of the array VR. LDVR .GE. 1; if /// JOBVR = 'V', LDVR .GE. N. ///</param> /// <param name="WORK"> /// (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) /// On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ///</param> /// <param name="LWORK"> /// (input) INTEGER /// The dimension of the array WORK. LWORK .GE. max(1,3*N), and /// if JOBVL = 'V' or JOBVR = 'V', LWORK .GE. 4*N. For good /// performance, LWORK must generally be larger. /// /// If LWORK = -1, then a workspace query is assumed; the routine /// only calculates the optimal size of the WORK array, returns /// this value as the first entry of the WORK array, and no error /// message related to LWORK is issued by XERBLA. ///</param> /// <param name="INFO"> /// (output) INTEGER /// = 0: successful exit /// .LT. 0: if INFO = -i, the i-th argument had an illegal value. /// .GT. 0: if INFO = i, the QR algorithm failed to compute all the /// eigenvalues, and no eigenvectors have been computed; /// elements i+1:N of WR and WI contain eigenvalues which /// have converged. ///</param> public void Run(string JOBVL, string JOBVR, int N, ref double[] A, int offset_a, int LDA, ref double[] WR, int offset_wr , ref double[] WI, int offset_wi, ref double[] VL, int offset_vl, int LDVL, ref double[] VR, int offset_vr, int LDVR, ref double[] WORK, int offset_work , int LWORK, ref int INFO) { #region Variables bool LQUERY = false; bool SCALEA = false; bool WANTVL = false; bool WANTVR = false; string SIDE = new string(' ', 1); int HSWORK = 0; int I = 0; int IBAL = 0; int IERR = 0; int IHI = 0; int ILO = 0; int ITAU = 0; int IWRK = 0; int K = 0; int MAXWRK = 0; int MINWRK = 0; int NOUT = 0; double ANRM = 0; double BIGNUM = 0; double CS = 0; double CSCALE = 0; double EPS = 0; double R = 0; double SCL = 0; double SMLNUM = 0; double SN = 0; int offset_select = 0; int offset_dum = 0; #endregion #region Array Index Correction int o_a = -1 - LDA + offset_a; int o_wr = -1 + offset_wr; int o_wi = -1 + offset_wi; int o_vl = -1 - LDVL + offset_vl; int o_vr = -1 - LDVR + offset_vr; int o_work = -1 + offset_work; #endregion #region Strings JOBVL = JOBVL.Substring(0, 1); JOBVR = JOBVR.Substring(0, 1); #endregion #region Prolog // * // * -- LAPACK driver routine (version 3.1) -- // * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. // * November 2006 // * // * .. Scalar Arguments .. // * .. // * .. Array Arguments .. // * .. // * // * Purpose // * ======= // * // * DGEEV computes for an N-by-N real nonsymmetric matrix A, the // * eigenvalues and, optionally, the left and/or right eigenvectors. // * // * The right eigenvector v(j) of A satisfies // * A * v(j) = lambda(j) * v(j) // * where lambda(j) is its eigenvalue. // * The left eigenvector u(j) of A satisfies // * u(j)**H * A = lambda(j) * u(j)**H // * where u(j)**H denotes the conjugate transpose of u(j). // * // * The computed eigenvectors are normalized to have Euclidean norm // * equal to 1 and largest component real. // * // * Arguments // * ========= // * // * JOBVL (input) CHARACTER*1 // * = 'N': left eigenvectors of A are not computed; // * = 'V': left eigenvectors of A are computed. // * // * JOBVR (input) CHARACTER*1 // * = 'N': right eigenvectors of A are not computed; // * = 'V': right eigenvectors of A are computed. // * // * N (input) INTEGER // * The order of the matrix A. N >= 0. // * // * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) // * On entry, the N-by-N matrix A. // * On exit, A has been overwritten. // * // * LDA (input) INTEGER // * The leading dimension of the array A. LDA >= max(1,N). // * // * WR (output) DOUBLE PRECISION array, dimension (N) // * WI (output) DOUBLE PRECISION array, dimension (N) // * WR and WI contain the real and imaginary parts, // * respectively, of the computed eigenvalues. Complex // * conjugate pairs of eigenvalues appear consecutively // * with the eigenvalue having the positive imaginary part // * first. // * // * VL (output) DOUBLE PRECISION array, dimension (LDVL,N) // * If JOBVL = 'V', the left eigenvectors u(j) are stored one // * after another in the columns of VL, in the same order // * as their eigenvalues. // * If JOBVL = 'N', VL is not referenced. // * If the j-th eigenvalue is real, then u(j) = VL(:,j), // * the j-th column of VL. // * If the j-th and (j+1)-st eigenvalues form a complex // * conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and // * u(j+1) = VL(:,j) - i*VL(:,j+1). // * // * LDVL (input) INTEGER // * The leading dimension of the array VL. LDVL >= 1; if // * JOBVL = 'V', LDVL >= N. // * // * VR (output) DOUBLE PRECISION array, dimension (LDVR,N) // * If JOBVR = 'V', the right eigenvectors v(j) are stored one // * after another in the columns of VR, in the same order // * as their eigenvalues. // * If JOBVR = 'N', VR is not referenced. // * If the j-th eigenvalue is real, then v(j) = VR(:,j), // * the j-th column of VR. // * If the j-th and (j+1)-st eigenvalues form a complex // * conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and // * v(j+1) = VR(:,j) - i*VR(:,j+1). // * // * LDVR (input) INTEGER // * The leading dimension of the array VR. LDVR >= 1; if // * JOBVR = 'V', LDVR >= N. // * // * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) // * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. // * // * LWORK (input) INTEGER // * The dimension of the array WORK. LWORK >= max(1,3*N), and // * if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good // * performance, LWORK must generally be larger. // * // * If LWORK = -1, then a workspace query is assumed; the routine // * only calculates the optimal size of the WORK array, returns // * this value as the first entry of the WORK array, and no error // * message related to LWORK is issued by XERBLA. // * // * INFO (output) INTEGER // * = 0: successful exit // * < 0: if INFO = -i, the i-th argument had an illegal value. // * > 0: if INFO = i, the QR algorithm failed to compute all the // * eigenvalues, and no eigenvectors have been computed; // * elements i+1:N of WR and WI contain eigenvalues which // * have converged. // * // * ===================================================================== // * // * .. Parameters .. // * .. // * .. Local Scalars .. // * .. // * .. Local Arrays .. // * .. // * .. External Subroutines .. // * .. // * .. External Functions .. // * .. // * .. Intrinsic Functions .. // INTRINSIC MAX, SQRT; // * .. // * .. Executable Statements .. // * // * Test the input arguments // * #endregion #region Body INFO = 0; LQUERY = (LWORK == -1); WANTVL = this._lsame.Run(JOBVL, "V"); WANTVR = this._lsame.Run(JOBVR, "V"); if ((!WANTVL) && (!this._lsame.Run(JOBVL, "N"))) { INFO = -1; } else { if ((!WANTVR) && (!this._lsame.Run(JOBVR, "N"))) { INFO = -2; } else { if (N < 0) { INFO = -3; } else { if (LDA < Math.Max(1, N)) { INFO = -5; } else { if (LDVL < 1 || (WANTVL && LDVL < N)) { INFO = -9; } else { if (LDVR < 1 || (WANTVR && LDVR < N)) { INFO = -11; } } } } } } // * // * Compute workspace // * (Note: Comments in the code beginning "Workspace:" describe the // * minimal amount of workspace needed at that point in the code, // * as well as the preferred amount for good performance. // * NB refers to the optimal block size for the immediately // * following subroutine, as returned by ILAENV. // * HSWORK refers to the workspace preferred by DHSEQR, as // * calculated below. HSWORK is computed assuming ILO=1 and IHI=N, // * the worst case.) // * if (INFO == 0) { if (N == 0) { MINWRK = 1; MAXWRK = 1; } else { MAXWRK = 2 * N + N * this._ilaenv.Run(1, "DGEHRD", " ", N, 1, N, 0); if (WANTVL) { MINWRK = 4 * N; MAXWRK = Math.Max(MAXWRK, 2 * N + (N - 1) * this._ilaenv.Run(1, "DORGHR", " ", N, 1, N, -1)); this._dhseqr.Run("S", "V", N, 1, N, ref A, offset_a , LDA, ref WR, offset_wr, ref WI, offset_wi, ref VL, offset_vl, LDVL, ref WORK, offset_work , -1, ref INFO); HSWORK = (int)WORK[1 + o_work]; MAXWRK = Math.Max(MAXWRK, Math.Max(N + 1, N + HSWORK)); MAXWRK = Math.Max(MAXWRK, 4 * N); } else { if (WANTVR) { MINWRK = 4 * N; MAXWRK = Math.Max(MAXWRK, 2 * N + (N - 1) * this._ilaenv.Run(1, "DORGHR", " ", N, 1, N, -1)); this._dhseqr.Run("S", "V", N, 1, N, ref A, offset_a , LDA, ref WR, offset_wr, ref WI, offset_wi, ref VR, offset_vr, LDVR, ref WORK, offset_work , -1, ref INFO); HSWORK = (int)WORK[1 + o_work]; MAXWRK = Math.Max(MAXWRK, Math.Max(N + 1, N + HSWORK)); MAXWRK = Math.Max(MAXWRK, 4 * N); } else { MINWRK = 3 * N; this._dhseqr.Run("E", "N", N, 1, N, ref A, offset_a , LDA, ref WR, offset_wr, ref WI, offset_wi, ref VR, offset_vr, LDVR, ref WORK, offset_work , -1, ref INFO); HSWORK = (int)WORK[1 + o_work]; MAXWRK = Math.Max(MAXWRK, Math.Max(N + 1, N + HSWORK)); } } MAXWRK = Math.Max(MAXWRK, MINWRK); } WORK[1 + o_work] = MAXWRK; // * if (LWORK < MINWRK && !LQUERY) { INFO = -13; } } // * if (INFO != 0) { this._xerbla.Run("DGEEV ", -INFO); return; } else { if (LQUERY) { return; } } // * // * Quick return if possible // * if (N == 0) { return; } // * // * Get machine constants // * EPS = this._dlamch.Run("P"); SMLNUM = this._dlamch.Run("S"); BIGNUM = ONE / SMLNUM; this._dlabad.Run(ref SMLNUM, ref BIGNUM); SMLNUM = Math.Sqrt(SMLNUM) / EPS; BIGNUM = ONE / SMLNUM; // * // * Scale A if max element outside range [SMLNUM,BIGNUM] // * ANRM = this._dlange.Run("M", N, N, A, offset_a, LDA, ref DUM, offset_dum); SCALEA = false; if (ANRM > ZERO && ANRM < SMLNUM) { SCALEA = true; CSCALE = SMLNUM; } else { if (ANRM > BIGNUM) { SCALEA = true; CSCALE = BIGNUM; } } if (SCALEA) { this._dlascl.Run("G", 0, 0, ANRM, CSCALE, N , N, ref A, offset_a, LDA, ref IERR); } // * // * Balance the matrix // * (Workspace: need N) // * IBAL = 1; this._dgebal.Run("B", N, ref A, offset_a, LDA, ref ILO, ref IHI , ref WORK, IBAL + o_work, ref IERR); // * // * Reduce to upper Hessenberg form // * (Workspace: need 3*N, prefer 2*N+N*NB) // * ITAU = IBAL + N; IWRK = ITAU + N; this._dgehrd.Run(N, ILO, IHI, ref A, offset_a, LDA, ref WORK, ITAU + o_work , ref WORK, IWRK + o_work, LWORK - IWRK + 1, ref IERR); // * if (WANTVL) { // * // * Want left eigenvectors // * Copy Householder vectors to VL // * FortranLib.Copy(ref SIDE, "L"); this._dlacpy.Run("L", N, N, A, offset_a, LDA, ref VL, offset_vl , LDVL); // * // * Generate orthogonal matrix in VL // * (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) // * this._dorghr.Run(N, ILO, IHI, ref VL, offset_vl, LDVL, WORK, ITAU + o_work , ref WORK, IWRK + o_work, LWORK - IWRK + 1, ref IERR); // * // * Perform QR iteration, accumulating Schur vectors in VL // * (Workspace: need N+1, prefer N+HSWORK (see comments) ) // * IWRK = ITAU; this._dhseqr.Run("S", "V", N, ILO, IHI, ref A, offset_a , LDA, ref WR, offset_wr, ref WI, offset_wi, ref VL, offset_vl, LDVL, ref WORK, IWRK + o_work , LWORK - IWRK + 1, ref INFO); // * if (WANTVR) { // * // * Want left and right eigenvectors // * Copy Schur vectors to VR // * FortranLib.Copy(ref SIDE, "B"); this._dlacpy.Run("F", N, N, VL, offset_vl, LDVL, ref VR, offset_vr , LDVR); } // * } else { if (WANTVR) { // * // * Want right eigenvectors // * Copy Householder vectors to VR // * FortranLib.Copy(ref SIDE, "R"); this._dlacpy.Run("L", N, N, A, offset_a, LDA, ref VR, offset_vr , LDVR); // * // * Generate orthogonal matrix in VR // * (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) // * this._dorghr.Run(N, ILO, IHI, ref VR, offset_vr, LDVR, WORK, ITAU + o_work , ref WORK, IWRK + o_work, LWORK - IWRK + 1, ref IERR); // * // * Perform QR iteration, accumulating Schur vectors in VR // * (Workspace: need N+1, prefer N+HSWORK (see comments) ) // * IWRK = ITAU; this._dhseqr.Run("S", "V", N, ILO, IHI, ref A, offset_a , LDA, ref WR, offset_wr, ref WI, offset_wi, ref VR, offset_vr, LDVR, ref WORK, IWRK + o_work , LWORK - IWRK + 1, ref INFO); // * } else { // * // * Compute eigenvalues only // * (Workspace: need N+1, prefer N+HSWORK (see comments) ) // * IWRK = ITAU; this._dhseqr.Run("E", "N", N, ILO, IHI, ref A, offset_a , LDA, ref WR, offset_wr, ref WI, offset_wi, ref VR, offset_vr, LDVR, ref WORK, IWRK + o_work , LWORK - IWRK + 1, ref INFO); } } // * // * If INFO > 0 from DHSEQR, then quit // * if (INFO > 0) { goto LABEL50; } // * if (WANTVL || WANTVR) { // * // * Compute left and/or right eigenvectors // * (Workspace: need 4*N) // * this._dtrevc.Run(SIDE, "B", ref SELECT, offset_select, N, A, offset_a, LDA , ref VL, offset_vl, LDVL, ref VR, offset_vr, LDVR, N, ref NOUT , ref WORK, IWRK + o_work, ref IERR); } // * if (WANTVL) { // * // * Undo balancing of left eigenvectors // * (Workspace: need N) // * this._dgebak.Run("B", "L", N, ILO, IHI, WORK, IBAL + o_work , N, ref VL, offset_vl, LDVL, ref IERR); // * // * Normalize left eigenvectors and make largest component real // * for (I = 1; I <= N; I++) { if (WI[I + o_wi] == ZERO) { SCL = ONE / this._dnrm2.Run(N, VL, 1 + I * LDVL + o_vl, 1); this._dscal.Run(N, SCL, ref VL, 1 + I * LDVL + o_vl, 1); } else { if (WI[I + o_wi] > ZERO) { SCL = ONE / this._dlapy2.Run(this._dnrm2.Run(N, VL, 1 + I * LDVL + o_vl, 1), this._dnrm2.Run(N, VL, 1 + (I + 1) * LDVL + o_vl, 1)); this._dscal.Run(N, SCL, ref VL, 1 + I * LDVL + o_vl, 1); this._dscal.Run(N, SCL, ref VL, 1 + (I + 1) * LDVL + o_vl, 1); for (K = 1; K <= N; K++) { WORK[IWRK + K - 1 + o_work] = Math.Pow(VL[K + I * LDVL + o_vl], 2) + Math.Pow(VL[K + (I + 1) * LDVL + o_vl], 2); } K = this._idamax.Run(N, WORK, IWRK + o_work, 1); this._dlartg.Run(VL[K + I * LDVL + o_vl], VL[K + (I + 1) * LDVL + o_vl], ref CS, ref SN, ref R); this._drot.Run(N, ref VL, 1 + I * LDVL + o_vl, 1, ref VL, 1 + (I + 1) * LDVL + o_vl, 1, CS , SN); VL[K + (I + 1) * LDVL + o_vl] = ZERO; } } } } // * if (WANTVR) { // * // * Undo balancing of right eigenvectors // * (Workspace: need N) // * this._dgebak.Run("B", "R", N, ILO, IHI, WORK, IBAL + o_work , N, ref VR, offset_vr, LDVR, ref IERR); // * // * Normalize right eigenvectors and make largest component real // * for (I = 1; I <= N; I++) { if (WI[I + o_wi] == ZERO) { SCL = ONE / this._dnrm2.Run(N, VR, 1 + I * LDVR + o_vr, 1); this._dscal.Run(N, SCL, ref VR, 1 + I * LDVR + o_vr, 1); } else { if (WI[I + o_wi] > ZERO) { SCL = ONE / this._dlapy2.Run(this._dnrm2.Run(N, VR, 1 + I * LDVR + o_vr, 1), this._dnrm2.Run(N, VR, 1 + (I + 1) * LDVR + o_vr, 1)); this._dscal.Run(N, SCL, ref VR, 1 + I * LDVR + o_vr, 1); this._dscal.Run(N, SCL, ref VR, 1 + (I + 1) * LDVR + o_vr, 1); for (K = 1; K <= N; K++) { WORK[IWRK + K - 1 + o_work] = Math.Pow(VR[K + I * LDVR + o_vr], 2) + Math.Pow(VR[K + (I + 1) * LDVR + o_vr], 2); } K = this._idamax.Run(N, WORK, IWRK + o_work, 1); this._dlartg.Run(VR[K + I * LDVR + o_vr], VR[K + (I + 1) * LDVR + o_vr], ref CS, ref SN, ref R); this._drot.Run(N, ref VR, 1 + I * LDVR + o_vr, 1, ref VR, 1 + (I + 1) * LDVR + o_vr, 1, CS , SN); VR[K + (I + 1) * LDVR + o_vr] = ZERO; } } } } // * // * Undo scaling if necessary // * LABEL50 :; if (SCALEA) { this._dlascl.Run("G", 0, 0, CSCALE, ANRM, N - INFO , 1, ref WR, INFO + 1 + o_wr, Math.Max(N - INFO, 1), ref IERR); this._dlascl.Run("G", 0, 0, CSCALE, ANRM, N - INFO , 1, ref WI, INFO + 1 + o_wi, Math.Max(N - INFO, 1), ref IERR); if (INFO > 0) { this._dlascl.Run("G", 0, 0, CSCALE, ANRM, ILO - 1 , 1, ref WR, offset_wr, N, ref IERR); this._dlascl.Run("G", 0, 0, CSCALE, ANRM, ILO - 1 , 1, ref WI, offset_wi, N, ref IERR); } } // * WORK[1 + o_work] = MAXWRK; return; // * // * End of DGEEV // * #endregion }
/// <summary> /// Purpose /// ======= /// /// DSTEQR computes all eigenvalues and, optionally, eigenvectors of a /// symmetric tridiagonal matrix using the implicit QL or QR method. /// The eigenvectors of a full or band symmetric matrix can also be found /// if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to /// tridiagonal form. /// ///</summary> /// <param name="COMPZ"> /// (input) CHARACTER*1 /// = 'N': Compute eigenvalues only. /// = 'V': Compute eigenvalues and eigenvectors of the original /// symmetric matrix. On entry, Z must contain the /// orthogonal matrix used to reduce the original matrix /// to tridiagonal form. /// = 'I': Compute eigenvalues and eigenvectors of the /// tridiagonal matrix. Z is initialized to the identity /// matrix. ///</param> /// <param name="N"> /// (input) INTEGER /// The order of the matrix. N .GE. 0. ///</param> /// <param name="D"> /// (input/output) DOUBLE PRECISION array, dimension (N) /// On entry, the diagonal elements of the tridiagonal matrix. /// On exit, if INFO = 0, the eigenvalues in ascending order. ///</param> /// <param name="E"> /// (input/output) DOUBLE PRECISION array, dimension (N-1) /// On entry, the (n-1) subdiagonal elements of the tridiagonal /// matrix. /// On exit, E has been destroyed. ///</param> /// <param name="Z"> /// (input/output) DOUBLE PRECISION array, dimension (LDZ, N) /// On entry, if COMPZ = 'V', then Z contains the orthogonal /// matrix used in the reduction to tridiagonal form. /// On exit, if INFO = 0, then if COMPZ = 'V', Z contains the /// orthonormal eigenvectors of the original symmetric matrix, /// and if COMPZ = 'I', Z contains the orthonormal eigenvectors /// of the symmetric tridiagonal matrix. /// If COMPZ = 'N', then Z is not referenced. ///</param> /// <param name="LDZ"> /// (input) INTEGER /// The leading dimension of the array Z. LDZ .GE. 1, and if /// eigenvectors are desired, then LDZ .GE. max(1,N). ///</param> /// <param name="WORK"> /// (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) /// If COMPZ = 'N', then WORK is not referenced. ///</param> /// <param name="INFO"> /// (output) INTEGER /// = 0: successful exit /// .LT. 0: if INFO = -i, the i-th argument had an illegal value /// .GT. 0: the algorithm has failed to find all the eigenvalues in /// a total of 30*N iterations; if INFO = i, then i /// elements of E have not converged to zero; on exit, D /// and E contain the elements of a symmetric tridiagonal /// matrix which is orthogonally similar to the original /// matrix. ///</param> public void Run(string COMPZ, int N, ref double[] D, int offset_d, ref double[] E, int offset_e, ref double[] Z, int offset_z, int LDZ , ref double[] WORK, int offset_work, ref int INFO) { #region Variables int I = 0; int ICOMPZ = 0; int II = 0; int ISCALE = 0; int J = 0; int JTOT = 0; int K = 0; int L = 0; int L1 = 0; int LEND = 0; int LENDM1 = 0; int LENDP1 = 0; int LENDSV = 0; int LM1 = 0; int LSV = 0; int M = 0; int MM = 0; int MM1 = 0; int NM1 = 0; int NMAXIT = 0; double ANORM = 0; double B = 0; double C = 0; double EPS = 0; double EPS2 = 0; double F = 0; double G = 0; double P = 0; double R = 0; double RT1 = 0; double RT2 = 0; double S = 0; double SAFMAX = 0; double SAFMIN = 0; double SSFMAX = 0; double SSFMIN = 0; double TST = 0; #endregion #region Array Index Correction int o_d = -1 + offset_d; int o_e = -1 + offset_e; int o_z = -1 - LDZ + offset_z; int o_work = -1 + offset_work; #endregion #region Strings COMPZ = COMPZ.Substring(0, 1); #endregion #region Prolog // * // * -- LAPACK routine (version 3.1) -- // * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. // * November 2006 // * // * .. Scalar Arguments .. // * .. // * .. Array Arguments .. // * .. // * // * Purpose // * ======= // * // * DSTEQR computes all eigenvalues and, optionally, eigenvectors of a // * symmetric tridiagonal matrix using the implicit QL or QR method. // * The eigenvectors of a full or band symmetric matrix can also be found // * if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to // * tridiagonal form. // * // * Arguments // * ========= // * // * COMPZ (input) CHARACTER*1 // * = 'N': Compute eigenvalues only. // * = 'V': Compute eigenvalues and eigenvectors of the original // * symmetric matrix. On entry, Z must contain the // * orthogonal matrix used to reduce the original matrix // * to tridiagonal form. // * = 'I': Compute eigenvalues and eigenvectors of the // * tridiagonal matrix. Z is initialized to the identity // * matrix. // * // * N (input) INTEGER // * The order of the matrix. N >= 0. // * // * D (input/output) DOUBLE PRECISION array, dimension (N) // * On entry, the diagonal elements of the tridiagonal matrix. // * On exit, if INFO = 0, the eigenvalues in ascending order. // * // * E (input/output) DOUBLE PRECISION array, dimension (N-1) // * On entry, the (n-1) subdiagonal elements of the tridiagonal // * matrix. // * On exit, E has been destroyed. // * // * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) // * On entry, if COMPZ = 'V', then Z contains the orthogonal // * matrix used in the reduction to tridiagonal form. // * On exit, if INFO = 0, then if COMPZ = 'V', Z contains the // * orthonormal eigenvectors of the original symmetric matrix, // * and if COMPZ = 'I', Z contains the orthonormal eigenvectors // * of the symmetric tridiagonal matrix. // * If COMPZ = 'N', then Z is not referenced. // * // * LDZ (input) INTEGER // * The leading dimension of the array Z. LDZ >= 1, and if // * eigenvectors are desired, then LDZ >= max(1,N). // * // * WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) // * If COMPZ = 'N', then WORK is not referenced. // * // * INFO (output) INTEGER // * = 0: successful exit // * < 0: if INFO = -i, the i-th argument had an illegal value // * > 0: the algorithm has failed to find all the eigenvalues in // * a total of 30*N iterations; if INFO = i, then i // * elements of E have not converged to zero; on exit, D // * and E contain the elements of a symmetric tridiagonal // * matrix which is orthogonally similar to the original // * matrix. // * // * ===================================================================== // * // * .. Parameters .. // * .. // * .. Local Scalars .. // * .. // * .. External Functions .. // * .. // * .. External Subroutines .. // * .. // * .. Intrinsic Functions .. // INTRINSIC ABS, MAX, SIGN, SQRT; // * .. // * .. Executable Statements .. // * // * Test the input parameters. // * #endregion #region Body INFO = 0; // * if (this._lsame.Run(COMPZ, "N")) { ICOMPZ = 0; } else { if (this._lsame.Run(COMPZ, "V")) { ICOMPZ = 1; } else { if (this._lsame.Run(COMPZ, "I")) { ICOMPZ = 2; } else { ICOMPZ = -1; } } } if (ICOMPZ < 0) { INFO = -1; } else { if (N < 0) { INFO = -2; } else { if ((LDZ < 1) || (ICOMPZ > 0 && LDZ < Math.Max(1, N))) { INFO = -6; } } } if (INFO != 0) { this._xerbla.Run("DSTEQR", -INFO); return; } // * // * Quick return if possible // * if (N == 0) { return; } // * if (N == 1) { if (ICOMPZ == 2) { Z[1 + 1 * LDZ + o_z] = ONE; } return; } // * // * Determine the unit roundoff and over/underflow thresholds. // * EPS = this._dlamch.Run("E"); EPS2 = Math.Pow(EPS, 2); SAFMIN = this._dlamch.Run("S"); SAFMAX = ONE / SAFMIN; SSFMAX = Math.Sqrt(SAFMAX) / THREE; SSFMIN = Math.Sqrt(SAFMIN) / EPS2; // * // * Compute the eigenvalues and eigenvectors of the tridiagonal // * matrix. // * if (ICOMPZ == 2) { this._dlaset.Run("Full", N, N, ZERO, ONE, ref Z, offset_z , LDZ); } // * NMAXIT = N * MAXIT; JTOT = 0; // * // * Determine where the matrix splits and choose QL or QR iteration // * for each block, according to whether top or bottom diagonal // * element is smaller. // * L1 = 1; NM1 = N - 1; // * LABEL10 :; if (L1 > N) { goto LABEL160; } if (L1 > 1) { E[L1 - 1 + o_e] = ZERO; } if (L1 <= NM1) { for (M = L1; M <= NM1; M++) { TST = Math.Abs(E[M + o_e]); if (TST == ZERO) { goto LABEL30; } if (TST <= (Math.Sqrt(Math.Abs(D[M + o_d])) * Math.Sqrt(Math.Abs(D[M + 1 + o_d]))) * EPS) { E[M + o_e] = ZERO; goto LABEL30; } } } M = N; // * LABEL30 :; L = L1; LSV = L; LEND = M; LENDSV = LEND; L1 = M + 1; if (LEND == L) { goto LABEL10; } // * // * Scale submatrix in rows and columns L to LEND // * ANORM = this._dlanst.Run("I", LEND - L + 1, D, L + o_d, E, L + o_e); ISCALE = 0; if (ANORM == ZERO) { goto LABEL10; } if (ANORM > SSFMAX) { ISCALE = 1; this._dlascl.Run("G", 0, 0, ANORM, SSFMAX, LEND - L + 1 , 1, ref D, L + o_d, N, ref INFO); this._dlascl.Run("G", 0, 0, ANORM, SSFMAX, LEND - L , 1, ref E, L + o_e, N, ref INFO); } else { if (ANORM < SSFMIN) { ISCALE = 2; this._dlascl.Run("G", 0, 0, ANORM, SSFMIN, LEND - L + 1 , 1, ref D, L + o_d, N, ref INFO); this._dlascl.Run("G", 0, 0, ANORM, SSFMIN, LEND - L , 1, ref E, L + o_e, N, ref INFO); } } // * // * Choose between QL and QR iteration // * if (Math.Abs(D[LEND + o_d]) < Math.Abs(D[L + o_d])) { LEND = LSV; L = LENDSV; } // * if (LEND > L) { // * // * QL Iteration // * // * Look for small subdiagonal element. // * LABEL40 :; if (L != LEND) { LENDM1 = LEND - 1; for (M = L; M <= LENDM1; M++) { TST = Math.Pow(Math.Abs(E[M + o_e]), 2); if (TST <= (EPS2 * Math.Abs(D[M + o_d])) * Math.Abs(D[M + 1 + o_d]) + SAFMIN) { goto LABEL60; } } } // * M = LEND; // * LABEL60 :; if (M < LEND) { E[M + o_e] = ZERO; } P = D[L + o_d]; if (M == L) { goto LABEL80; } // * // * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 // * to compute its eigensystem. // * if (M == L + 1) { if (ICOMPZ > 0) { this._dlaev2.Run(D[L + o_d], E[L + o_e], D[L + 1 + o_d], ref RT1, ref RT2, ref C , ref S); WORK[L + o_work] = C; WORK[N - 1 + L + o_work] = S; this._dlasr.Run("R", "V", "B", N, 2, WORK, L + o_work , WORK, N - 1 + L + o_work, ref Z, 1 + L * LDZ + o_z, LDZ); } else { this._dlae2.Run(D[L + o_d], E[L + o_e], D[L + 1 + o_d], ref RT1, ref RT2); } D[L + o_d] = RT1; D[L + 1 + o_d] = RT2; E[L + o_e] = ZERO; L += 2; if (L <= LEND) { goto LABEL40; } goto LABEL140; } // * if (JTOT == NMAXIT) { goto LABEL140; } JTOT += 1; // * // * Form shift. // * G = (D[L + 1 + o_d] - P) / (TWO * E[L + o_e]); R = this._dlapy2.Run(G, ONE); G = D[M + o_d] - P + (E[L + o_e] / (G + FortranLib.Sign(R, G))); // * S = ONE; C = ONE; P = ZERO; // * // * Inner loop // * MM1 = M - 1; for (I = MM1; I >= L; I += -1) { F = S * E[I + o_e]; B = C * E[I + o_e]; this._dlartg.Run(G, F, ref C, ref S, ref R); if (I != M - 1) { E[I + 1 + o_e] = R; } G = D[I + 1 + o_d] - P; R = (D[I + o_d] - G) * S + TWO * C * B; P = S * R; D[I + 1 + o_d] = G + P; G = C * R - B; // * // * If eigenvectors are desired, then save rotations. // * if (ICOMPZ > 0) { WORK[I + o_work] = C; WORK[N - 1 + I + o_work] = -S; } // * } // * // * If eigenvectors are desired, then apply saved rotations. // * if (ICOMPZ > 0) { MM = M - L + 1; this._dlasr.Run("R", "V", "B", N, MM, WORK, L + o_work , WORK, N - 1 + L + o_work, ref Z, 1 + L * LDZ + o_z, LDZ); } // * D[L + o_d] -= P; E[L + o_e] = G; goto LABEL40; // * // * Eigenvalue found. // * LABEL80 :; D[L + o_d] = P; // * L += 1; if (L <= LEND) { goto LABEL40; } goto LABEL140; // * } else { // * // * QR Iteration // * // * Look for small superdiagonal element. // * LABEL90 :; if (L != LEND) { LENDP1 = LEND + 1; for (M = L; M >= LENDP1; M += -1) { TST = Math.Pow(Math.Abs(E[M - 1 + o_e]), 2); if (TST <= (EPS2 * Math.Abs(D[M + o_d])) * Math.Abs(D[M - 1 + o_d]) + SAFMIN) { goto LABEL110; } } } // * M = LEND; // * LABEL110 :; if (M > LEND) { E[M - 1 + o_e] = ZERO; } P = D[L + o_d]; if (M == L) { goto LABEL130; } // * // * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 // * to compute its eigensystem. // * if (M == L - 1) { if (ICOMPZ > 0) { this._dlaev2.Run(D[L - 1 + o_d], E[L - 1 + o_e], D[L + o_d], ref RT1, ref RT2, ref C , ref S); WORK[M + o_work] = C; WORK[N - 1 + M + o_work] = S; this._dlasr.Run("R", "V", "F", N, 2, WORK, M + o_work , WORK, N - 1 + M + o_work, ref Z, 1 + (L - 1) * LDZ + o_z, LDZ); } else { this._dlae2.Run(D[L - 1 + o_d], E[L - 1 + o_e], D[L + o_d], ref RT1, ref RT2); } D[L - 1 + o_d] = RT1; D[L + o_d] = RT2; E[L - 1 + o_e] = ZERO; L -= 2; if (L >= LEND) { goto LABEL90; } goto LABEL140; } // * if (JTOT == NMAXIT) { goto LABEL140; } JTOT += 1; // * // * Form shift. // * G = (D[L - 1 + o_d] - P) / (TWO * E[L - 1 + o_e]); R = this._dlapy2.Run(G, ONE); G = D[M + o_d] - P + (E[L - 1 + o_e] / (G + FortranLib.Sign(R, G))); // * S = ONE; C = ONE; P = ZERO; // * // * Inner loop // * LM1 = L - 1; for (I = M; I <= LM1; I++) { F = S * E[I + o_e]; B = C * E[I + o_e]; this._dlartg.Run(G, F, ref C, ref S, ref R); if (I != M) { E[I - 1 + o_e] = R; } G = D[I + o_d] - P; R = (D[I + 1 + o_d] - G) * S + TWO * C * B; P = S * R; D[I + o_d] = G + P; G = C * R - B; // * // * If eigenvectors are desired, then save rotations. // * if (ICOMPZ > 0) { WORK[I + o_work] = C; WORK[N - 1 + I + o_work] = S; } // * } // * // * If eigenvectors are desired, then apply saved rotations. // * if (ICOMPZ > 0) { MM = L - M + 1; this._dlasr.Run("R", "V", "F", N, MM, WORK, M + o_work , WORK, N - 1 + M + o_work, ref Z, 1 + M * LDZ + o_z, LDZ); } // * D[L + o_d] -= P; E[LM1 + o_e] = G; goto LABEL90; // * // * Eigenvalue found. // * LABEL130 :; D[L + o_d] = P; // * L -= 1; if (L >= LEND) { goto LABEL90; } goto LABEL140; // * } // * // * Undo scaling if necessary // * LABEL140 :; if (ISCALE == 1) { this._dlascl.Run("G", 0, 0, SSFMAX, ANORM, LENDSV - LSV + 1 , 1, ref D, LSV + o_d, N, ref INFO); this._dlascl.Run("G", 0, 0, SSFMAX, ANORM, LENDSV - LSV , 1, ref E, LSV + o_e, N, ref INFO); } else { if (ISCALE == 2) { this._dlascl.Run("G", 0, 0, SSFMIN, ANORM, LENDSV - LSV + 1 , 1, ref D, LSV + o_d, N, ref INFO); this._dlascl.Run("G", 0, 0, SSFMIN, ANORM, LENDSV - LSV , 1, ref E, LSV + o_e, N, ref INFO); } } // * // * Check for no convergence to an eigenvalue after a total // * of N*MAXIT iterations. // * if (JTOT < NMAXIT) { goto LABEL10; } for (I = 1; I <= N - 1; I++) { if (E[I + o_e] != ZERO) { INFO += 1; } } goto LABEL190; // * // * Order eigenvalues and eigenvectors. // * LABEL160 :; if (ICOMPZ == 0) { // * // * Use Quick Sort // * this._dlasrt.Run("I", N, ref D, offset_d, ref INFO); // * } else { // * // * Use Selection Sort to minimize swaps of eigenvectors // * for (II = 2; II <= N; II++) { I = II - 1; K = I; P = D[I + o_d]; for (J = II; J <= N; J++) { if (D[J + o_d] < P) { K = J; P = D[J + o_d]; } } if (K != I) { D[K + o_d] = D[I + o_d]; D[I + o_d] = P; this._dswap.Run(N, ref Z, 1 + I * LDZ + o_z, 1, ref Z, 1 + K * LDZ + o_z, 1); } } } // * LABEL190 :; return; // * // * End of DSTEQR // * #endregion }
/// <summary> /// Purpose /// ======= /// /// DTRCON estimates the reciprocal of the condition number of a /// triangular matrix A, in either the 1-norm or the infinity-norm. /// /// The norm of A is computed and an estimate is obtained for /// norm(inv(A)), then the reciprocal of the condition number is /// computed as /// RCOND = 1 / ( norm(A) * norm(inv(A)) ). /// ///</summary> /// <param name="NORM"> /// (input) CHARACTER*1 /// Specifies whether the 1-norm condition number or the /// infinity-norm condition number is required: /// = '1' or 'O': 1-norm; /// = 'I': Infinity-norm. ///</param> /// <param name="UPLO"> /// (input) CHARACTER*1 /// = 'U': A is upper triangular; /// = 'L': A is lower triangular. ///</param> /// <param name="DIAG"> /// (input) CHARACTER*1 /// = 'N': A is non-unit triangular; /// = 'U': A is unit triangular. ///</param> /// <param name="N"> /// (input) INTEGER /// The order of the matrix A. N .GE. 0. ///</param> /// <param name="A"> /// (input) DOUBLE PRECISION array, dimension (LDA,N) /// The triangular matrix A. If UPLO = 'U', the leading N-by-N /// upper triangular part of the array A contains the upper /// triangular matrix, and the strictly lower triangular part of /// A is not referenced. If UPLO = 'L', the leading N-by-N lower /// triangular part of the array A contains the lower triangular /// matrix, and the strictly upper triangular part of A is not /// referenced. If DIAG = 'U', the diagonal elements of A are /// also not referenced and are assumed to be 1. ///</param> /// <param name="LDA"> /// (input) INTEGER /// The leading dimension of the array A. LDA .GE. max(1,N). ///</param> /// <param name="RCOND"> /// (output) DOUBLE PRECISION /// The reciprocal of the condition number of the matrix A, /// computed as RCOND = 1/(norm(A) * norm(inv(A))). ///</param> /// <param name="WORK"> /// (workspace) DOUBLE PRECISION array, dimension (3*N) ///</param> /// <param name="IWORK"> /// (workspace) INTEGER array, dimension (N) ///</param> /// <param name="INFO"> /// (output) INTEGER /// = 0: successful exit /// .LT. 0: if INFO = -i, the i-th argument had an illegal value ///</param> public void Run(string NORM, string UPLO, string DIAG, int N, double[] A, int offset_a, int LDA , ref double RCOND, ref double[] WORK, int offset_work, ref int[] IWORK, int offset_iwork, ref int INFO) { #region Variables bool NOUNIT = false; bool ONENRM = false; bool UPPER = false; string NORMIN = new string(' ', 1); int IX = 0; int KASE = 0; int KASE1 = 0; double AINVNM = 0; double ANORM = 0; double SCALE = 0; double SMLNUM = 0; double XNORM = 0; #endregion #region Array Index Correction int o_a = -1 - LDA + offset_a; int o_work = -1 + offset_work; int o_iwork = -1 + offset_iwork; #endregion #region Strings NORM = NORM.Substring(0, 1); UPLO = UPLO.Substring(0, 1); DIAG = DIAG.Substring(0, 1); #endregion #region Prolog // * // * -- LAPACK routine (version 3.0) -- // * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., // * Courant Institute, Argonne National Lab, and Rice University // * March 31, 1993 // * // * .. Scalar Arguments .. // * .. // * .. Array Arguments .. // * .. // * // * Purpose // * ======= // * // * DTRCON estimates the reciprocal of the condition number of a // * triangular matrix A, in either the 1-norm or the infinity-norm. // * // * The norm of A is computed and an estimate is obtained for // * norm(inv(A)), then the reciprocal of the condition number is // * computed as // * RCOND = 1 / ( norm(A) * norm(inv(A)) ). // * // * Arguments // * ========= // * // * NORM (input) CHARACTER*1 // * Specifies whether the 1-norm condition number or the // * infinity-norm condition number is required: // * = '1' or 'O': 1-norm; // * = 'I': Infinity-norm. // * // * UPLO (input) CHARACTER*1 // * = 'U': A is upper triangular; // * = 'L': A is lower triangular. // * // * DIAG (input) CHARACTER*1 // * = 'N': A is non-unit triangular; // * = 'U': A is unit triangular. // * // * N (input) INTEGER // * The order of the matrix A. N >= 0. // * // * A (input) DOUBLE PRECISION array, dimension (LDA,N) // * The triangular matrix A. If UPLO = 'U', the leading N-by-N // * upper triangular part of the array A contains the upper // * triangular matrix, and the strictly lower triangular part of // * A is not referenced. If UPLO = 'L', the leading N-by-N lower // * triangular part of the array A contains the lower triangular // * matrix, and the strictly upper triangular part of A is not // * referenced. If DIAG = 'U', the diagonal elements of A are // * also not referenced and are assumed to be 1. // * // * LDA (input) INTEGER // * The leading dimension of the array A. LDA >= max(1,N). // * // * RCOND (output) DOUBLE PRECISION // * The reciprocal of the condition number of the matrix A, // * computed as RCOND = 1/(norm(A) * norm(inv(A))). // * // * WORK (workspace) DOUBLE PRECISION array, dimension (3*N) // * // * IWORK (workspace) INTEGER array, dimension (N) // * // * INFO (output) INTEGER // * = 0: successful exit // * < 0: if INFO = -i, the i-th argument had an illegal value // * // * ===================================================================== // * // * .. Parameters .. // * .. // * .. Local Scalars .. // * .. // * .. External Functions .. // * .. // * .. External Subroutines .. // * .. // * .. Intrinsic Functions .. // INTRINSIC ABS, DBLE, MAX; // * .. // * .. Executable Statements .. // * // * Test the input parameters. // * #endregion #region Body INFO = 0; UPPER = this._lsame.Run(UPLO, "U"); ONENRM = NORM == "1" || this._lsame.Run(NORM, "O"); NOUNIT = this._lsame.Run(DIAG, "N"); // * if (!ONENRM && !this._lsame.Run(NORM, "I")) { INFO = -1; } else { if (!UPPER && !this._lsame.Run(UPLO, "L")) { INFO = -2; } else { if (!NOUNIT && !this._lsame.Run(DIAG, "U")) { INFO = -3; } else { if (N < 0) { INFO = -4; } else { if (LDA < Math.Max(1, N)) { INFO = -6; } } } } } if (INFO != 0) { this._xerbla.Run("DTRCON", -INFO); return; } // * // * Quick return if possible // * if (N == 0) { RCOND = ONE; return; } // * RCOND = ZERO; SMLNUM = this._dlamch.Run("Safe minimum") * Convert.ToDouble(Math.Max(1, N)); // * // * Compute the norm of the triangular matrix A. // * ANORM = this._dlantr.Run(NORM, UPLO, DIAG, N, N, A, offset_a, LDA, ref WORK, offset_work); // * // * Continue only if ANORM > 0. // * if (ANORM > ZERO) { // * // * Estimate the norm of the inverse of A. // * AINVNM = ZERO; FortranLib.Copy(ref NORMIN, "N"); if (ONENRM) { KASE1 = 1; } else { KASE1 = 2; } KASE = 0; LABEL10 :; this._dlacon.Run(N, ref WORK, N + 1 + o_work, ref WORK, offset_work, ref IWORK, offset_iwork, ref AINVNM, ref KASE); if (KASE != 0) { if (KASE == KASE1) { // * // * Multiply by inv(A). // * this._dlatrs.Run(UPLO, "No transpose", DIAG, NORMIN, N, A, offset_a , LDA, ref WORK, offset_work, ref SCALE, ref WORK, 2 * N + 1 + o_work, ref INFO); } else { // * // * Multiply by inv(A'). // * this._dlatrs.Run(UPLO, "Transpose", DIAG, NORMIN, N, A, offset_a , LDA, ref WORK, offset_work, ref SCALE, ref WORK, 2 * N + 1 + o_work, ref INFO); } FortranLib.Copy(ref NORMIN, "Y"); // * // * Multiply by 1/SCALE if doing so will not cause overflow. // * if (SCALE != ONE) { IX = this._idamax.Run(N, WORK, offset_work, 1); XNORM = Math.Abs(WORK[IX + o_work]); if (SCALE < XNORM * SMLNUM || SCALE == ZERO) { goto LABEL20; } this._drscl.Run(N, SCALE, ref WORK, offset_work, 1); } goto LABEL10; } // * // * Compute the estimate of the reciprocal condition number. // * if (AINVNM != ZERO) { RCOND = (ONE / ANORM) / AINVNM; } } // * LABEL20 :; return; // * // * End of DTRCON // * #endregion }
/// <param name="T"> /// * x = b ///</param> /// <param name="LDT"> /// integer /// ldt is the leading dimension of the array t. ///</param> /// <param name="N"> /// integer /// n is the order of the system. ///</param> /// <param name="B"> /// double precision(n). /// b contains the right hand side of the system. ///</param> /// <param name="JOB"> /// integer /// job specifies what kind of system is to be solved. /// if job is /// /// 00 solve t*x=b, t lower triangular, /// 01 solve t*x=b, t upper triangular, /// 10 solve trans(t)*x=b, t lower triangular, /// 11 solve trans(t)*x=b, t upper triangular. ///</param> /// <param name="INFO"> /// integer /// info contains zero if the system is nonsingular. /// otherwise info contains the index of /// the first zero diagonal element of t. ///</param> public void Run(double[] T, int offset_t, int LDT, int N, ref double[] B, int offset_b, int JOB, ref int INFO) { #region Variables double TEMP = 0; int CASE = 0; int J = 0; int JJ = 0; #endregion #region Array Index Correction int o_t = -1 - LDT + offset_t; int o_b = -1 + offset_b; #endregion #region Prolog // c // c // c dtrsl solves systems of the form // c // c t * x = b // c or // c trans(t) * x = b // c // c where t is a triangular matrix of order n. here trans(t) // c denotes the transpose of the matrix t. // c // c on entry // c // c t double precision(ldt,n) // c t contains the matrix of the system. the zero // c elements of the matrix are not referenced, and // c the corresponding elements of the array can be // c used to store other information. // c // c ldt integer // c ldt is the leading dimension of the array t. // c // c n integer // c n is the order of the system. // c // c b double precision(n). // c b contains the right hand side of the system. // c // c job integer // c job specifies what kind of system is to be solved. // c if job is // c // c 00 solve t*x=b, t lower triangular, // c 01 solve t*x=b, t upper triangular, // c 10 solve trans(t)*x=b, t lower triangular, // c 11 solve trans(t)*x=b, t upper triangular. // c // c on return // c // c b b contains the solution, if info .eq. 0. // c otherwise b is unaltered. // c // c info integer // c info contains zero if the system is nonsingular. // c otherwise info contains the index of // c the first zero diagonal element of t. // c // c linpack. this version dated 08/14/78 . // c g. w. stewart, university of maryland, argonne national lab. // c // c subroutines and functions // c // c blas daxpy,ddot // c fortran mod // c // c internal variables // c // INTRINSIC MOD; // c // c begin block permitting ...exits to 150 // c // c check for zero diagonal elements. // c #endregion #region Body for (INFO = 1; INFO <= N; INFO++) { // c ......exit if (T[INFO + INFO * LDT + o_t] == 0.0E0) { goto LABEL150; } } INFO = 0; // c // c determine the task and go to it. // c CASE = 1; if (FortranLib.Mod(JOB, 10) != 0) { CASE = 2; } if (FortranLib.Mod(JOB, 100) / 10 != 0) { CASE += 2; } switch (CASE) { case 1: goto LABEL20; case 2: goto LABEL50; case 3: goto LABEL80; case 4: goto LABEL110; } // c // c solve t*x=b for t lower triangular // c LABEL20 :; B[1 + o_b] /= T[1 + 1 * LDT + o_t]; if (N < 2) { goto LABEL40; } for (J = 2; J <= N; J++) { TEMP = -B[J - 1 + o_b]; this._daxpy.Run(N - J + 1, TEMP, T, J + (J - 1) * LDT + o_t, 1, ref B, J + o_b, 1); B[J + o_b] /= T[J + J * LDT + o_t]; } LABEL40 :; goto LABEL140; // c // c solve t*x=b for t upper triangular. // c LABEL50 :; B[N + o_b] /= T[N + N * LDT + o_t]; if (N < 2) { goto LABEL70; } for (JJ = 2; JJ <= N; JJ++) { J = N - JJ + 1; TEMP = -B[J + 1 + o_b]; this._daxpy.Run(J, TEMP, T, 1 + (J + 1) * LDT + o_t, 1, ref B, 1 + o_b, 1); B[J + o_b] /= T[J + J * LDT + o_t]; } LABEL70 :; goto LABEL140; // c // c solve trans(t)*x=b for t lower triangular. // c LABEL80 :; B[N + o_b] /= T[N + N * LDT + o_t]; if (N < 2) { goto LABEL100; } for (JJ = 2; JJ <= N; JJ++) { J = N - JJ + 1; B[J + o_b] -= this._ddot.Run(JJ - 1, T, J + 1 + J * LDT + o_t, 1, B, J + 1 + o_b, 1); B[J + o_b] /= T[J + J * LDT + o_t]; } LABEL100 :; goto LABEL140; // c // c solve trans(t)*x=b for t upper triangular. // c LABEL110 :; B[1 + o_b] /= T[1 + 1 * LDT + o_t]; if (N < 2) { goto LABEL130; } for (J = 2; J <= N; J++) { B[J + o_b] -= this._ddot.Run(J - 1, T, 1 + J * LDT + o_t, 1, B, 1 + o_b, 1); B[J + o_b] /= T[J + J * LDT + o_t]; } LABEL130 :; LABEL140 :; LABEL150 :; return; #endregion }
public void Run(int N, double[] DX, int offset_dx, int INCX, ref double[] DY, int offset_dy, int INCY) { #region Variables int I = 0; int IX = 0; int IY = 0; int M = 0; int MP1 = 0; #endregion #region Array Index Correction int o_dx = -1 + offset_dx; int o_dy = -1 + offset_dy; #endregion // c // c copies a vector, x, to a vector, y. // c uses unrolled loops for increments equal to one. // c jack dongarra, linpack, 3/11/78. // c modified 12/3/93, array(1) declarations changed to array(*) // c // c #region Body if (N <= 0) { return; } if (INCX == 1 && INCY == 1) { goto LABEL20; } // c // c code for unequal increments or equal increments // c not equal to 1 // c IX = 1; IY = 1; if (INCX < 0) { IX = (-N + 1) * INCX + 1; } if (INCY < 0) { IY = (-N + 1) * INCY + 1; } for (I = 1; I <= N; I++) { DY[IY + o_dy] = DX[IX + o_dx]; IX += INCX; IY += INCY; } return; // c // c code for both increments equal to 1 // c // c // c clean-up loop // c LABEL20 : M = FortranLib.Mod(N, 7); if (M == 0) { goto LABEL40; } for (I = 1; I <= M; I++) { DY[I + o_dy] = DX[I + o_dx]; } if (N < 7) { return; } LABEL40 : MP1 = M + 1; for (I = MP1; I <= N; I += 7) { DY[I + o_dy] = DX[I + o_dx]; DY[I + 1 + o_dy] = DX[I + 1 + o_dx]; DY[I + 2 + o_dy] = DX[I + 2 + o_dx]; DY[I + 3 + o_dy] = DX[I + 3 + o_dx]; DY[I + 4 + o_dy] = DX[I + 4 + o_dx]; DY[I + 5 + o_dy] = DX[I + 5 + o_dx]; DY[I + 6 + o_dy] = DX[I + 6 + o_dx]; } return; #endregion }
/// <summary> /// Purpose /// ======= /// /// DLALSD uses the singular value decomposition of A to solve the least /// squares problem of finding X to minimize the Euclidean norm of each /// column of A*X-B, where A is N-by-N upper bidiagonal, and X and B /// are N-by-NRHS. The solution X overwrites B. /// /// The singular values of A smaller than RCOND times the largest /// singular value are treated as zero in solving the least squares /// problem; in this case a minimum norm solution is returned. /// The actual singular values are returned in D in ascending order. /// /// This code makes very mild assumptions about floating point /// arithmetic. It will work on machines with a guard digit in /// add/subtract, or on those binary machines without guard digits /// which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. /// It could conceivably fail on hexadecimal or decimal machines /// without guard digits, but we know of none. /// ///</summary> /// <param name="UPLO"> /// (input) CHARACTER*1 /// = 'U': D and E define an upper bidiagonal matrix. /// = 'L': D and E define a lower bidiagonal matrix. ///</param> /// <param name="SMLSIZ"> /// (input) INTEGER /// The maximum size of the subproblems at the bottom of the /// computation tree. ///</param> /// <param name="N"> /// (input) INTEGER /// The dimension of the bidiagonal matrix. N .GE. 0. ///</param> /// <param name="NRHS"> /// (input) INTEGER /// The number of columns of B. NRHS must be at least 1. ///</param> /// <param name="D"> /// (input/output) DOUBLE PRECISION array, dimension (N) /// On entry D contains the main diagonal of the bidiagonal /// matrix. On exit, if INFO = 0, D contains its singular values. ///</param> /// <param name="E"> /// (input/output) DOUBLE PRECISION array, dimension (N-1) /// Contains the super-diagonal entries of the bidiagonal matrix. /// On exit, E has been destroyed. ///</param> /// <param name="B"> /// (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) /// On input, B contains the right hand sides of the least /// squares problem. On output, B contains the solution X. ///</param> /// <param name="LDB"> /// (input) INTEGER /// The leading dimension of B in the calling subprogram. /// LDB must be at least max(1,N). ///</param> /// <param name="RCOND"> /// (input) DOUBLE PRECISION /// The singular values of A less than or equal to RCOND times /// the largest singular value are treated as zero in solving /// the least squares problem. If RCOND is negative, /// machine precision is used instead. /// For example, if diag(S)*X=B were the least squares problem, /// where diag(S) is a diagonal matrix of singular values, the /// solution would be X(i) = B(i) / S(i) if S(i) is greater than /// RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to /// RCOND*max(S). ///</param> /// <param name="RANK"> /// (output) INTEGER /// The number of singular values of A greater than RCOND times /// the largest singular value. ///</param> /// <param name="WORK"> /// (workspace) DOUBLE PRECISION array, dimension at least /// (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2), /// where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1). ///</param> /// <param name="IWORK"> /// (workspace) INTEGER array, dimension at least /// (3*N*NLVL + 11*N) ///</param> /// <param name="INFO"> /// (output) INTEGER /// = 0: successful exit. /// .LT. 0: if INFO = -i, the i-th argument had an illegal value. /// .GT. 0: The algorithm failed to compute an singular value while /// working on the submatrix lying in rows and columns /// INFO/(N+1) through MOD(INFO,N+1). ///</param> public void Run(string UPLO, int SMLSIZ, int N, int NRHS, ref double[] D, int offset_d, ref double[] E, int offset_e , ref double[] B, int offset_b, int LDB, double RCOND, ref int RANK, ref double[] WORK, int offset_work, ref int[] IWORK, int offset_iwork , ref int INFO) { #region Variables int BX = 0; int BXST = 0; int C = 0; int DIFL = 0; int DIFR = 0; int GIVCOL = 0; int GIVNUM = 0; int GIVPTR = 0; int I = 0; int ICMPQ1 = 0; int ICMPQ2 = 0; int IWK = 0; int J = 0; int K = 0; int NLVL = 0; int NM1 = 0; int NSIZE = 0; int NSUB = 0; int NWORK = 0; int PERM = 0; int POLES = 0; int S = 0; int SIZEI = 0; int SMLSZP = 0; int SQRE = 0; int ST = 0; int ST1 = 0; int U = 0; int VT = 0; int Z = 0; double CS = 0; double EPS = 0; double ORGNRM = 0; double R = 0; double RCND = 0; double SN = 0; double TOL = 0; #endregion #region Array Index Correction int o_d = -1 + offset_d; int o_e = -1 + offset_e; int o_b = -1 - LDB + offset_b; int o_work = -1 + offset_work; int o_iwork = -1 + offset_iwork; #endregion #region Strings UPLO = UPLO.Substring(0, 1); #endregion #region Prolog // * // * -- LAPACK routine (version 3.1) -- // * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. // * November 2006 // * // * .. Scalar Arguments .. // * .. // * .. Array Arguments .. // * .. // * // * Purpose // * ======= // * // * DLALSD uses the singular value decomposition of A to solve the least // * squares problem of finding X to minimize the Euclidean norm of each // * column of A*X-B, where A is N-by-N upper bidiagonal, and X and B // * are N-by-NRHS. The solution X overwrites B. // * // * The singular values of A smaller than RCOND times the largest // * singular value are treated as zero in solving the least squares // * problem; in this case a minimum norm solution is returned. // * The actual singular values are returned in D in ascending order. // * // * This code makes very mild assumptions about floating point // * arithmetic. It will work on machines with a guard digit in // * add/subtract, or on those binary machines without guard digits // * which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. // * It could conceivably fail on hexadecimal or decimal machines // * without guard digits, but we know of none. // * // * Arguments // * ========= // * // * UPLO (input) CHARACTER*1 // * = 'U': D and E define an upper bidiagonal matrix. // * = 'L': D and E define a lower bidiagonal matrix. // * // * SMLSIZ (input) INTEGER // * The maximum size of the subproblems at the bottom of the // * computation tree. // * // * N (input) INTEGER // * The dimension of the bidiagonal matrix. N >= 0. // * // * NRHS (input) INTEGER // * The number of columns of B. NRHS must be at least 1. // * // * D (input/output) DOUBLE PRECISION array, dimension (N) // * On entry D contains the main diagonal of the bidiagonal // * matrix. On exit, if INFO = 0, D contains its singular values. // * // * E (input/output) DOUBLE PRECISION array, dimension (N-1) // * Contains the super-diagonal entries of the bidiagonal matrix. // * On exit, E has been destroyed. // * // * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) // * On input, B contains the right hand sides of the least // * squares problem. On output, B contains the solution X. // * // * LDB (input) INTEGER // * The leading dimension of B in the calling subprogram. // * LDB must be at least max(1,N). // * // * RCOND (input) DOUBLE PRECISION // * The singular values of A less than or equal to RCOND times // * the largest singular value are treated as zero in solving // * the least squares problem. If RCOND is negative, // * machine precision is used instead. // * For example, if diag(S)*X=B were the least squares problem, // * where diag(S) is a diagonal matrix of singular values, the // * solution would be X(i) = B(i) / S(i) if S(i) is greater than // * RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to // * RCOND*max(S). // * // * RANK (output) INTEGER // * The number of singular values of A greater than RCOND times // * the largest singular value. // * // * WORK (workspace) DOUBLE PRECISION array, dimension at least // * (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2), // * where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1). // * // * IWORK (workspace) INTEGER array, dimension at least // * (3*N*NLVL + 11*N) // * // * INFO (output) INTEGER // * = 0: successful exit. // * < 0: if INFO = -i, the i-th argument had an illegal value. // * > 0: The algorithm failed to compute an singular value while // * working on the submatrix lying in rows and columns // * INFO/(N+1) through MOD(INFO,N+1). // * // * Further Details // * =============== // * // * Based on contributions by // * Ming Gu and Ren-Cang Li, Computer Science Division, University of // * California at Berkeley, USA // * Osni Marques, LBNL/NERSC, USA // * // * ===================================================================== // * // * .. Parameters .. // * .. // * .. Local Scalars .. // * .. // * .. External Functions .. // * .. // * .. External Subroutines .. // * .. // * .. Intrinsic Functions .. // INTRINSIC ABS, DBLE, INT, LOG, SIGN; // * .. // * .. Executable Statements .. // * // * Test the input parameters. // * #endregion #region Body INFO = 0; // * if (N < 0) { INFO = -3; } else { if (NRHS < 1) { INFO = -4; } else { if ((LDB < 1) || (LDB < N)) { INFO = -8; } } } if (INFO != 0) { this._xerbla.Run("DLALSD", -INFO); return; } // * EPS = this._dlamch.Run("Epsilon"); // * // * Set up the tolerance. // * if ((RCOND <= ZERO) || (RCOND >= ONE)) { RCND = EPS; } else { RCND = RCOND; } // * RANK = 0; // * // * Quick return if possible. // * if (N == 0) { return; } else { if (N == 1) { if (D[1 + o_d] == ZERO) { this._dlaset.Run("A", 1, NRHS, ZERO, ZERO, ref B, offset_b , LDB); } else { RANK = 1; this._dlascl.Run("G", 0, 0, D[1 + o_d], ONE, 1 , NRHS, ref B, offset_b, LDB, ref INFO); D[1 + o_d] = Math.Abs(D[1 + o_d]); } return; } } // * // * Rotate the matrix if it is lower bidiagonal. // * if (UPLO == "L") { for (I = 1; I <= N - 1; I++) { this._dlartg.Run(D[I + o_d], E[I + o_e], ref CS, ref SN, ref R); D[I + o_d] = R; E[I + o_e] = SN * D[I + 1 + o_d]; D[I + 1 + o_d] *= CS; if (NRHS == 1) { this._drot.Run(1, ref B, I + 1 * LDB + o_b, 1, ref B, I + 1 + 1 * LDB + o_b, 1, CS , SN); } else { WORK[I * 2 - 1 + o_work] = CS; WORK[I * 2 + o_work] = SN; } } if (NRHS > 1) { for (I = 1; I <= NRHS; I++) { for (J = 1; J <= N - 1; J++) { CS = WORK[J * 2 - 1 + o_work]; SN = WORK[J * 2 + o_work]; this._drot.Run(1, ref B, J + I * LDB + o_b, 1, ref B, J + 1 + I * LDB + o_b, 1, CS , SN); } } } } // * // * Scale. // * NM1 = N - 1; ORGNRM = this._dlanst.Run("M", N, D, offset_d, E, offset_e); if (ORGNRM == ZERO) { this._dlaset.Run("A", N, NRHS, ZERO, ZERO, ref B, offset_b , LDB); return; } // * this._dlascl.Run("G", 0, 0, ORGNRM, ONE, N , 1, ref D, offset_d, N, ref INFO); this._dlascl.Run("G", 0, 0, ORGNRM, ONE, NM1 , 1, ref E, offset_e, NM1, ref INFO); // * // * If N is smaller than the minimum divide size SMLSIZ, then solve // * the problem with another solver. // * if (N <= SMLSIZ) { NWORK = 1 + N * N; this._dlaset.Run("A", N, N, ZERO, ONE, ref WORK, offset_work , N); this._dlasdq.Run("U", 0, N, N, 0, NRHS , ref D, offset_d, ref E, offset_e, ref WORK, offset_work, N, ref WORK, offset_work, N , ref B, offset_b, LDB, ref WORK, NWORK + o_work, ref INFO); if (INFO != 0) { return; } TOL = RCND * Math.Abs(D[this._idamax.Run(N, D, offset_d, 1) + o_d]); for (I = 1; I <= N; I++) { if (D[I + o_d] <= TOL) { this._dlaset.Run("A", 1, NRHS, ZERO, ZERO, ref B, I + 1 * LDB + o_b , LDB); } else { this._dlascl.Run("G", 0, 0, D[I + o_d], ONE, 1 , NRHS, ref B, I + 1 * LDB + o_b, LDB, ref INFO); RANK += 1; } } this._dgemm.Run("T", "N", N, NRHS, N, ONE , WORK, offset_work, N, B, offset_b, LDB, ZERO, ref WORK, NWORK + o_work , N); this._dlacpy.Run("A", N, NRHS, WORK, NWORK + o_work, N, ref B, offset_b , LDB); // * // * Unscale. // * this._dlascl.Run("G", 0, 0, ONE, ORGNRM, N , 1, ref D, offset_d, N, ref INFO); this._dlasrt.Run("D", N, ref D, offset_d, ref INFO); this._dlascl.Run("G", 0, 0, ORGNRM, ONE, N , NRHS, ref B, offset_b, LDB, ref INFO); // * return; } // * // * Book-keeping and setting up some constants. // * NLVL = Convert.ToInt32(Math.Truncate(Math.Log(Convert.ToDouble(N) / Convert.ToDouble(SMLSIZ + 1)) / Math.Log(TWO))) + 1; // * SMLSZP = SMLSIZ + 1; // * U = 1; VT = 1 + SMLSIZ * N; DIFL = VT + SMLSZP * N; DIFR = DIFL + NLVL * N; Z = DIFR + NLVL * N * 2; C = Z + NLVL * N; S = C + N; POLES = S + N; GIVNUM = POLES + 2 * NLVL * N; BX = GIVNUM + 2 * NLVL * N; NWORK = BX + N * NRHS; // * SIZEI = 1 + N; K = SIZEI + N; GIVPTR = K + N; PERM = GIVPTR + N; GIVCOL = PERM + NLVL * N; IWK = GIVCOL + NLVL * N * 2; // * ST = 1; SQRE = 0; ICMPQ1 = 1; ICMPQ2 = 0; NSUB = 0; // * for (I = 1; I <= N; I++) { if (Math.Abs(D[I + o_d]) < EPS) { D[I + o_d] = FortranLib.Sign(EPS, D[I + o_d]); } } // * for (I = 1; I <= NM1; I++) { if ((Math.Abs(E[I + o_e]) < EPS) || (I == NM1)) { NSUB += 1; IWORK[NSUB + o_iwork] = ST; // * // * Subproblem found. First determine its size and then // * apply divide and conquer on it. // * if (I < NM1) { // * // * A subproblem with E(I) small for I < NM1. // * NSIZE = I - ST + 1; IWORK[SIZEI + NSUB - 1 + o_iwork] = NSIZE; } else { if (Math.Abs(E[I + o_e]) >= EPS) { // * // * A subproblem with E(NM1) not too small but I = NM1. // * NSIZE = N - ST + 1; IWORK[SIZEI + NSUB - 1 + o_iwork] = NSIZE; } else { // * // * A subproblem with E(NM1) small. This implies an // * 1-by-1 subproblem at D(N), which is not solved // * explicitly. // * NSIZE = I - ST + 1; IWORK[SIZEI + NSUB - 1 + o_iwork] = NSIZE; NSUB += 1; IWORK[NSUB + o_iwork] = N; IWORK[SIZEI + NSUB - 1 + o_iwork] = 1; this._dcopy.Run(NRHS, B, N + 1 * LDB + o_b, LDB, ref WORK, BX + NM1 + o_work, N); } } ST1 = ST - 1; if (NSIZE == 1) { // * // * This is a 1-by-1 subproblem and is not solved // * explicitly. // * this._dcopy.Run(NRHS, B, ST + 1 * LDB + o_b, LDB, ref WORK, BX + ST1 + o_work, N); } else { if (NSIZE <= SMLSIZ) { // * // * This is a small subproblem and is solved by DLASDQ. // * this._dlaset.Run("A", NSIZE, NSIZE, ZERO, ONE, ref WORK, VT + ST1 + o_work , N); this._dlasdq.Run("U", 0, NSIZE, NSIZE, 0, NRHS , ref D, ST + o_d, ref E, ST + o_e, ref WORK, VT + ST1 + o_work, N, ref WORK, NWORK + o_work, N , ref B, ST + 1 * LDB + o_b, LDB, ref WORK, NWORK + o_work, ref INFO); if (INFO != 0) { return; } this._dlacpy.Run("A", NSIZE, NRHS, B, ST + 1 * LDB + o_b, LDB, ref WORK, BX + ST1 + o_work , N); } else { // * // * A large problem. Solve it using divide and conquer. // * this._dlasda.Run(ICMPQ1, SMLSIZ, NSIZE, SQRE, ref D, ST + o_d, ref E, ST + o_e , ref WORK, U + ST1 + o_work, N, ref WORK, VT + ST1 + o_work, ref IWORK, K + ST1 + o_iwork, ref WORK, DIFL + ST1 + o_work, ref WORK, DIFR + ST1 + o_work , ref WORK, Z + ST1 + o_work, ref WORK, POLES + ST1 + o_work, ref IWORK, GIVPTR + ST1 + o_iwork, ref IWORK, GIVCOL + ST1 + o_iwork, N, ref IWORK, PERM + ST1 + o_iwork , ref WORK, GIVNUM + ST1 + o_work, ref WORK, C + ST1 + o_work, ref WORK, S + ST1 + o_work, ref WORK, NWORK + o_work, ref IWORK, IWK + o_iwork, ref INFO); if (INFO != 0) { return; } BXST = BX + ST1; this._dlalsa.Run(ICMPQ2, SMLSIZ, NSIZE, NRHS, ref B, ST + 1 * LDB + o_b, LDB , ref WORK, BXST + o_work, N, WORK, U + ST1 + o_work, N, WORK, VT + ST1 + o_work, IWORK, K + ST1 + o_iwork , WORK, DIFL + ST1 + o_work, WORK, DIFR + ST1 + o_work, WORK, Z + ST1 + o_work, WORK, POLES + ST1 + o_work, IWORK, GIVPTR + ST1 + o_iwork, IWORK, GIVCOL + ST1 + o_iwork , N, IWORK, PERM + ST1 + o_iwork, WORK, GIVNUM + ST1 + o_work, WORK, C + ST1 + o_work, WORK, S + ST1 + o_work, ref WORK, NWORK + o_work , ref IWORK, IWK + o_iwork, ref INFO); if (INFO != 0) { return; } } } ST = I + 1; } } // * // * Apply the singular values and treat the tiny ones as zero. // * TOL = RCND * Math.Abs(D[this._idamax.Run(N, D, offset_d, 1) + o_d]); // * for (I = 1; I <= N; I++) { // * // * Some of the elements in D can be negative because 1-by-1 // * subproblems were not solved explicitly. // * if (Math.Abs(D[I + o_d]) <= TOL) { this._dlaset.Run("A", 1, NRHS, ZERO, ZERO, ref WORK, BX + I - 1 + o_work , N); } else { RANK += 1; this._dlascl.Run("G", 0, 0, D[I + o_d], ONE, 1 , NRHS, ref WORK, BX + I - 1 + o_work, N, ref INFO); } D[I + o_d] = Math.Abs(D[I + o_d]); } // * // * Now apply back the right singular vectors. // * ICMPQ2 = 1; for (I = 1; I <= NSUB; I++) { ST = IWORK[I + o_iwork]; ST1 = ST - 1; NSIZE = IWORK[SIZEI + I - 1 + o_iwork]; BXST = BX + ST1; if (NSIZE == 1) { this._dcopy.Run(NRHS, WORK, BXST + o_work, N, ref B, ST + 1 * LDB + o_b, LDB); } else { if (NSIZE <= SMLSIZ) { this._dgemm.Run("T", "N", NSIZE, NRHS, NSIZE, ONE , WORK, VT + ST1 + o_work, N, WORK, BXST + o_work, N, ZERO, ref B, ST + 1 * LDB + o_b , LDB); } else { this._dlalsa.Run(ICMPQ2, SMLSIZ, NSIZE, NRHS, ref WORK, BXST + o_work, N , ref B, ST + 1 * LDB + o_b, LDB, WORK, U + ST1 + o_work, N, WORK, VT + ST1 + o_work, IWORK, K + ST1 + o_iwork , WORK, DIFL + ST1 + o_work, WORK, DIFR + ST1 + o_work, WORK, Z + ST1 + o_work, WORK, POLES + ST1 + o_work, IWORK, GIVPTR + ST1 + o_iwork, IWORK, GIVCOL + ST1 + o_iwork , N, IWORK, PERM + ST1 + o_iwork, WORK, GIVNUM + ST1 + o_work, WORK, C + ST1 + o_work, WORK, S + ST1 + o_work, ref WORK, NWORK + o_work , ref IWORK, IWK + o_iwork, ref INFO); if (INFO != 0) { return; } } } } // * // * Unscale and sort the singular values. // * this._dlascl.Run("G", 0, 0, ONE, ORGNRM, N , 1, ref D, offset_d, N, ref INFO); this._dlasrt.Run("D", N, ref D, offset_d, ref INFO); this._dlascl.Run("G", 0, 0, ORGNRM, ONE, N , NRHS, ref B, offset_b, LDB, ref INFO); // * return; // * // * End of DLALSD // * #endregion }
public void Run(int N, IFAREN FCN, ref double X, ref double[] Y, int offset_y, double XEND, ref double HMAX , ref double H, double[] RTOL, int offset_rtol, double[] ATOL, int offset_atol, int ITOL, int IPRINT, ISOLOUT SOLOUT , int IOUT, ref int IDID, int NMAX, double UROUND, int METH, int NSTIFF , double SAFE, double BETA, double FAC1, double FAC2, ref double[] Y1, int offset_y1, ref double[] K1, int offset_k1 , ref double[] K2, int offset_k2, ref double[] K3, int offset_k3, ref double[] K4, int offset_k4, ref double[] K5, int offset_k5, ref double[] K6, int offset_k6, ref double[] YSTI, int offset_ysti , ref double[] CONT, int offset_cont, int[] ICOMP, int offset_icomp, int NRD, double[] RPAR, int offset_rpar, int[] IPAR, int offset_ipar, ref int NFCN , ref int NSTEP, ref int NACCPT, ref int NREJCT) { #region Variables bool REJECT = false; bool LAST = false; #endregion #region Implicit Variables double FACOLD = 0; double EXPO1 = 0; double FACC1 = 0; double FACC2 = 0; double POSNEG = 0; double ATOLI = 0; double RTOLI = 0; double HLAMB = 0; int IASTI = 0; int IORD = 0; int IRTRN = 0; int I = 0; double A21 = 0; double A31 = 0; double A32 = 0; double A41 = 0; double A42 = 0; double A43 = 0; double A51 = 0; double A52 = 0; double A53 = 0; double A54 = 0; double A61 = 0; double A62 = 0; double A63 = 0; double A64 = 0; double A65 = 0; double XPH = 0; double A71 = 0; double A73 = 0; double A74 = 0; double A75 = 0; double A76 = 0; int J = 0; double D1 = 0; double D3 = 0; double D4 = 0; double D5 = 0; double D6 = 0; double D7 = 0; double E1 = 0; double E3 = 0; double E4 = 0; double E5 = 0; double E6 = 0; double E7 = 0; double ERR = 0; double SK = 0; double FAC11 = 0; double FAC = 0; double HNEW = 0; double STNUM = 0; double STDEN = 0; int NONSTI = 0; double YD0 = 0; double YDIFF = 0; double BSPL = 0; double C2 = 0; double C3 = 0; double C4 = 0; double C5 = 0; #endregion #region Array Index Correction int o_y = -1 + offset_y; int o_rtol = -1 + offset_rtol; int o_atol = -1 + offset_atol; int o_y1 = -1 + offset_y1; int o_k1 = -1 + offset_k1; int o_k2 = -1 + offset_k2; int o_k3 = -1 + offset_k3; int o_k4 = -1 + offset_k4; int o_k5 = -1 + offset_k5; int o_k6 = -1 + offset_k6; int o_ysti = -1 + offset_ysti; int o_cont = -1 + offset_cont; int o_icomp = -1 + offset_icomp; int o_rpar = -1 + offset_rpar; int o_ipar = -1 + offset_ipar; #endregion // C ---------------------------------------------------------- // C CORE INTEGRATOR FOR DOPRI5 // C PARAMETERS SAME AS IN DOPRI5 WITH WORKSPACE ADDED // C ---------------------------------------------------------- // C DECLARATIONS // C ---------------------------------------------------------- // C *** *** *** *** *** *** *** // C INITIALISATIONS // C *** *** *** *** *** *** *** #region Body if (METH == 1) { this._cdopri.Run(ref C2, ref C3, ref C4, ref C5, ref E1, ref E3 , ref E4, ref E5, ref E6, ref E7, ref A21, ref A31 , ref A32, ref A41, ref A42, ref A43, ref A51, ref A52 , ref A53, ref A54, ref A61, ref A62, ref A63, ref A64 , ref A65, ref A71, ref A73, ref A74, ref A75, ref A76 , ref D1, ref D3, ref D4, ref D5, ref D6, ref D7); } FACOLD = 1.0E-4; EXPO1 = 0.2E0 - BETA * 0.75E0; FACC1 = 1.0E0 / FAC1; FACC2 = 1.0E0 / FAC2; POSNEG = FortranLib.Sign(1.0E0, XEND - X); // C --- INITIAL PREPARATIONS ATOLI = ATOL[1 + o_atol]; RTOLI = RTOL[1 + o_rtol]; LAST = false; HLAMB = 0.0E0; IASTI = 0; FCN.Run(N, X, Y, offset_y, ref K1, offset_k1, RPAR, offset_rpar, IPAR[1 + o_ipar]); HMAX = Math.Abs(HMAX); IORD = 5; if (H == 0.0E0) { H = this._hinit.Run(N, FCN, X, Y, offset_y, XEND, POSNEG, K1, offset_k1, ref K2, offset_k2, ref K3, offset_k3, IORD, HMAX, ATOL, offset_atol, RTOL, offset_rtol, ITOL, RPAR, offset_rpar, IPAR, offset_ipar); } NFCN += 2; REJECT = false; XOLD.v = X; if (IOUT != 0) { IRTRN = 1; HOUT.v = H; SOLOUT.Run(NACCPT + 1, XOLD.v, X, Y, offset_y, N, CONT, offset_cont , ICOMP, offset_icomp, NRD, RPAR, offset_rpar, IPAR[1 + o_ipar], IRTRN); if (IRTRN < 0) { goto LABEL79; } } else { IRTRN = 0; } // C --- BASIC INTEGRATION STEP LABEL1 :; if (NSTEP > NMAX) { goto LABEL78; } if (0.1E0 * Math.Abs(H) <= Math.Abs(X) * UROUND) { goto LABEL77; } if ((X + 1.01E0 * H - XEND) * POSNEG > 0.0E0) { H = XEND - X; LAST = true; } NSTEP += 1; // C --- THE FIRST 6 STAGES if (IRTRN >= 2) { FCN.Run(N, X, Y, offset_y, ref K1, offset_k1, RPAR, offset_rpar, IPAR[1 + o_ipar]); } for (I = 1; I <= N; I++) { Y1[I + o_y1] = Y[I + o_y] + H * A21 * K1[I + o_k1]; } FCN.Run(N, X + C2 * H, Y1, offset_y1, ref K2, offset_k2, RPAR, offset_rpar, IPAR[1 + o_ipar]); for (I = 1; I <= N; I++) { Y1[I + o_y1] = Y[I + o_y] + H * (A31 * K1[I + o_k1] + A32 * K2[I + o_k2]); } FCN.Run(N, X + C3 * H, Y1, offset_y1, ref K3, offset_k3, RPAR, offset_rpar, IPAR[1 + o_ipar]); for (I = 1; I <= N; I++) { Y1[I + o_y1] = Y[I + o_y] + H * (A41 * K1[I + o_k1] + A42 * K2[I + o_k2] + A43 * K3[I + o_k3]); } FCN.Run(N, X + C4 * H, Y1, offset_y1, ref K4, offset_k4, RPAR, offset_rpar, IPAR[1 + o_ipar]); for (I = 1; I <= N; I++) { Y1[I + o_y1] = Y[I + o_y] + H * (A51 * K1[I + o_k1] + A52 * K2[I + o_k2] + A53 * K3[I + o_k3] + A54 * K4[I + o_k4]); } FCN.Run(N, X + C5 * H, Y1, offset_y1, ref K5, offset_k5, RPAR, offset_rpar, IPAR[1 + o_ipar]); for (I = 1; I <= N; I++) { YSTI[I + o_ysti] = Y[I + o_y] + H * (A61 * K1[I + o_k1] + A62 * K2[I + o_k2] + A63 * K3[I + o_k3] + A64 * K4[I + o_k4] + A65 * K5[I + o_k5]); } XPH = X + H; FCN.Run(N, XPH, YSTI, offset_ysti, ref K6, offset_k6, RPAR, offset_rpar, IPAR[1 + o_ipar]); for (I = 1; I <= N; I++) { Y1[I + o_y1] = Y[I + o_y] + H * (A71 * K1[I + o_k1] + A73 * K3[I + o_k3] + A74 * K4[I + o_k4] + A75 * K5[I + o_k5] + A76 * K6[I + o_k6]); } FCN.Run(N, XPH, Y1, offset_y1, ref K2, offset_k2, RPAR, offset_rpar, IPAR[1 + o_ipar]); if (IOUT >= 2) { for (J = 1; J <= NRD; J++) { I = ICOMP[J + o_icomp]; CONT[4 * NRD + J + o_cont] = H * (D1 * K1[I + o_k1] + D3 * K3[I + o_k3] + D4 * K4[I + o_k4] + D5 * K5[I + o_k5] + D6 * K6[I + o_k6] + D7 * K2[I + o_k2]); } } for (I = 1; I <= N; I++) { K4[I + o_k4] = (E1 * K1[I + o_k1] + E3 * K3[I + o_k3] + E4 * K4[I + o_k4] + E5 * K5[I + o_k5] + E6 * K6[I + o_k6] + E7 * K2[I + o_k2]) * H; } NFCN += 6; // C --- ERROR ESTIMATION ERR = 0.0E0; if (ITOL == 0) { for (I = 1; I <= N; I++) { SK = ATOLI + RTOLI * Math.Max(Math.Abs(Y[I + o_y]), Math.Abs(Y1[I + o_y1])); ERR += Math.Pow(K4[I + o_k4] / SK, 2); } } else { for (I = 1; I <= N; I++) { SK = ATOL[I + o_atol] + RTOL[I + o_rtol] * Math.Max(Math.Abs(Y[I + o_y]), Math.Abs(Y1[I + o_y1])); ERR += Math.Pow(K4[I + o_k4] / SK, 2); } } ERR = Math.Sqrt(ERR / N); // C --- COMPUTATION OF HNEW FAC11 = Math.Pow(ERR, EXPO1); // C --- LUND-STABILIZATION FAC = FAC11 / Math.Pow(FACOLD, BETA); // C --- WE REQUIRE FAC1 <= HNEW/H <= FAC2 FAC = Math.Max(FACC2, Math.Min(FACC1, FAC / SAFE)); HNEW = H / FAC; if (ERR <= 1.0E0) { // C --- STEP IS ACCEPTED FACOLD = Math.Max(ERR, 1.0E-4); NACCPT += 1; // C ------- STIFFNESS DETECTION if (FortranLib.Mod(NACCPT, NSTIFF) == 0 || IASTI > 0) { STNUM = 0.0E0; STDEN = 0.0E0; for (I = 1; I <= N; I++) { STNUM += Math.Pow(K2[I + o_k2] - K6[I + o_k6], 2); STDEN += Math.Pow(Y1[I + o_y1] - YSTI[I + o_ysti], 2); } if (STDEN > 0.0E0) { HLAMB = H * Math.Sqrt(STNUM / STDEN); } if (HLAMB > 3.25E0) { NONSTI = 0; IASTI += 1; if (IASTI == 15) { if (IPRINT > 0) { ; //ERROR-ERRORWRITE(IPRINT,*)' THE PROBLEM SEEMS TO BECOME STIFF AT X = ',X } if (IPRINT <= 0) { goto LABEL76; } } } else { NONSTI += 1; if (NONSTI == 6) { IASTI = 0; } } } if (IOUT >= 2) { for (J = 1; J <= NRD; J++) { I = ICOMP[J + o_icomp]; YD0 = Y[I + o_y]; YDIFF = Y1[I + o_y1] - YD0; BSPL = H * K1[I + o_k1] - YDIFF; CONT[J + o_cont] = Y[I + o_y]; CONT[NRD + J + o_cont] = YDIFF; CONT[2 * NRD + J + o_cont] = BSPL; CONT[3 * NRD + J + o_cont] = -H * K2[I + o_k2] + YDIFF - BSPL; } } for (I = 1; I <= N; I++) { K1[I + o_k1] = K2[I + o_k2]; Y[I + o_y] = Y1[I + o_y1]; } XOLD.v = X; X = XPH; if (IOUT != 0) { HOUT.v = H; SOLOUT.Run(NACCPT + 1, XOLD.v, X, Y, offset_y, N, CONT, offset_cont , ICOMP, offset_icomp, NRD, RPAR, offset_rpar, IPAR[1 + o_ipar], IRTRN); if (IRTRN < 0) { goto LABEL79; } } // C ------- NORMAL EXIT if (LAST) { H = HNEW; IDID = 1; return; } if (Math.Abs(HNEW) > HMAX) { HNEW = POSNEG * HMAX; } if (REJECT) { HNEW = POSNEG * Math.Min(Math.Abs(HNEW), Math.Abs(H)); } REJECT = false; } else { // C --- STEP IS REJECTED HNEW = H / Math.Min(FACC1, FAC11 / SAFE); REJECT = true; if (NACCPT >= 1) { NREJCT += 1; } LAST = false; } H = HNEW; goto LABEL1; // C --- FAIL EXIT LABEL76 :; IDID = -4; return; LABEL77 :; if (IPRINT > 0) { ; //ERROR-ERRORWRITE(IPRINT,979)X } if (IPRINT > 0) { ; //ERROR-ERRORWRITE(IPRINT,*)' STEP SIZE T0O SMALL, H=',H } IDID = -3; return; LABEL78 :; if (IPRINT > 0) { ; //ERROR-ERRORWRITE(IPRINT,979)X } if (IPRINT > 0) { ; //ERROR-ERRORWRITE(IPRINT,*)' MORE THAN NMAX =',NMAX,'STEPS ARE NEEDED' } IDID = -2; return; LABEL79 :; if (IPRINT > 0) { ; //ERROR-ERRORWRITE(IPRINT,979)X } IDID = 2; return; #endregion }
/// <summary> /// Purpose /// ======= /// /// DLAQR0 computes the eigenvalues of a Hessenberg matrix H /// and, optionally, the matrices T and Z from the Schur decomposition /// H = Z T Z**T, where T is an upper quasi-triangular matrix (the /// Schur form), and Z is the orthogonal matrix of Schur vectors. /// /// Optionally Z may be postmultiplied into an input orthogonal /// matrix Q so that this routine can give the Schur factorization /// of a matrix A which has been reduced to the Hessenberg form H /// by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. /// ///</summary> /// <param name="WANTT"> /// (input) LOGICAL /// = .TRUE. : the full Schur form T is required; /// = .FALSE.: only eigenvalues are required. ///</param> /// <param name="WANTZ"> /// (input) LOGICAL /// = .TRUE. : the matrix of Schur vectors Z is required; /// = .FALSE.: Schur vectors are not required. ///</param> /// <param name="N"> /// (input) INTEGER /// The order of the matrix H. N .GE. 0. ///</param> /// <param name="ILO"> /// (input) INTEGER ///</param> /// <param name="IHI"> /// (input) INTEGER /// It is assumed that H is already upper triangular in rows /// and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, /// H(ILO,ILO-1) is zero. ILO and IHI are normally set by a /// previous call to DGEBAL, and then passed to DGEHRD when the /// matrix output by DGEBAL is reduced to Hessenberg form. /// Otherwise, ILO and IHI should be set to 1 and N, /// respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. /// If N = 0, then ILO = 1 and IHI = 0. ///</param> /// <param name="H"> /// (input/output) DOUBLE PRECISION array, dimension (LDH,N) /// On entry, the upper Hessenberg matrix H. /// On exit, if INFO = 0 and WANTT is .TRUE., then H contains /// the upper quasi-triangular matrix T from the Schur /// decomposition (the Schur form); 2-by-2 diagonal blocks /// (corresponding to complex conjugate pairs of eigenvalues) /// are returned in standard form, with H(i,i) = H(i+1,i+1) /// and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is /// .FALSE., then the contents of H are unspecified on exit. /// (The output value of H when INFO.GT.0 is given under the /// description of INFO below.) /// /// This subroutine may explicitly set H(i,j) = 0 for i.GT.j and /// j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. ///</param> /// <param name="LDH"> /// (input) INTEGER /// The leading dimension of the array H. LDH .GE. max(1,N). ///</param> /// <param name="WR"> /// (output) DOUBLE PRECISION array, dimension (IHI) ///</param> /// <param name="WI"> /// (output) DOUBLE PRECISION array, dimension (IHI) /// The real and imaginary parts, respectively, of the computed /// eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI) /// and WI(ILO:IHI). If two eigenvalues are computed as a /// complex conjugate pair, they are stored in consecutive /// elements of WR and WI, say the i-th and (i+1)th, with /// WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then /// the eigenvalues are stored in the same order as on the /// diagonal of the Schur form returned in H, with /// WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal /// block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and /// WI(i+1) = -WI(i). ///</param> /// <param name="ILOZ"> /// (input) INTEGER ///</param> /// <param name="IHIZ"> /// (input) INTEGER /// Specify the rows of Z to which transformations must be /// applied if WANTZ is .TRUE.. /// 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. ///</param> /// <param name="Z"> /// (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) /// If WANTZ is .FALSE., then Z is not referenced. /// If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is /// replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the /// orthogonal Schur factor of H(ILO:IHI,ILO:IHI). /// (The output value of Z when INFO.GT.0 is given under /// the description of INFO below.) ///</param> /// <param name="LDZ"> /// (input) INTEGER /// The leading dimension of the array Z. if WANTZ is .TRUE. /// then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. ///</param> /// <param name="WORK"> /// (workspace/output) DOUBLE PRECISION array, dimension LWORK /// On exit, if LWORK = -1, WORK(1) returns an estimate of /// the optimal value for LWORK. ///</param> /// <param name="LWORK"> /// (input) INTEGER /// The dimension of the array WORK. LWORK .GE. max(1,N) /// is sufficient, but LWORK typically as large as 6*N may /// be required for optimal performance. A workspace query /// to determine the optimal workspace size is recommended. /// /// If LWORK = -1, then DLAQR0 does a workspace query. /// In this case, DLAQR0 checks the input parameters and /// estimates the optimal workspace size for the given /// values of N, ILO and IHI. The estimate is returned /// in WORK(1). No error message related to LWORK is /// issued by XERBLA. Neither H nor Z are accessed. /// ///</param> /// <param name="INFO"> /// (output) INTEGER /// = 0: successful exit /// .GT. 0: if INFO = i, DLAQR0 failed to compute all of /// the eigenvalues. Elements 1:ilo-1 and i+1:n of WR /// and WI contain those eigenvalues which have been /// successfully computed. (Failures are rare.) /// /// If INFO .GT. 0 and WANT is .FALSE., then on exit, /// the remaining unconverged eigenvalues are the eigen- /// values of the upper Hessenberg matrix rows and /// columns ILO through INFO of the final, output /// value of H. /// /// If INFO .GT. 0 and WANTT is .TRUE., then on exit /// /// (*) (initial value of H)*U = U*(final value of H) /// /// where U is an orthogonal matrix. The final /// value of H is upper Hessenberg and quasi-triangular /// in rows and columns INFO+1 through IHI. /// /// If INFO .GT. 0 and WANTZ is .TRUE., then on exit /// /// (final value of Z(ILO:IHI,ILOZ:IHIZ) /// = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U /// /// where U is the orthogonal matrix in (*) (regard- /// less of the value of WANTT.) /// /// If INFO .GT. 0 and WANTZ is .FALSE., then Z is not /// accessed. /// ///</param> public void Run(bool WANTT, bool WANTZ, int N, int ILO, int IHI, ref double[] H, int offset_h , int LDH, ref double[] WR, int offset_wr, ref double[] WI, int offset_wi, int ILOZ, int IHIZ, ref double[] Z, int offset_z , int LDZ, ref double[] WORK, int offset_work, int LWORK, ref int INFO) { #region Variables double AA = 0; double BB = 0; double CC = 0; double CS = 0; double DD = 0; double SN = 0; double SS = 0; double SWAP = 0; int I = 0; int INF = 0; int IT = 0; int ITMAX = 0; int K = 0; int KACC22 = 0; int KBOT = 0; int KDU = 0; int KS = 0; int KT = 0; int KTOP = 0; int KU = 0; int KV = 0; int KWH = 0; int KWTOP = 0; int KWV = 0; int LD = 0; int LS = 0; int LWKOPT = 0; int NDFL = 0; int NH = 0; int NHO = 0; int NIBBLE = 0; int NMIN = 0; int NS = 0; int NSMAX = 0; int NSR = 0; int NVE = 0; int NW = 0; int NWMAX = 0; int NWR = 0; bool NWINC = false; bool SORTED = false; string JBCMPZ = new string(' ', 2); int offset_zdum = 0; #endregion #region Array Index Correction int o_h = -1 - LDH + offset_h; int o_wr = -1 + offset_wr; int o_wi = -1 + offset_wi; int o_z = -1 - LDZ + offset_z; int o_work = -1 + offset_work; #endregion #region Prolog // * // * -- LAPACK auxiliary routine (version 3.1) -- // * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. // * November 2006 // * // * .. Scalar Arguments .. // * .. // * .. Array Arguments .. // * .. // * // * Purpose // * ======= // * // * DLAQR0 computes the eigenvalues of a Hessenberg matrix H // * and, optionally, the matrices T and Z from the Schur decomposition // * H = Z T Z**T, where T is an upper quasi-triangular matrix (the // * Schur form), and Z is the orthogonal matrix of Schur vectors. // * // * Optionally Z may be postmultiplied into an input orthogonal // * matrix Q so that this routine can give the Schur factorization // * of a matrix A which has been reduced to the Hessenberg form H // * by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. // * // * Arguments // * ========= // * // * WANTT (input) LOGICAL // * = .TRUE. : the full Schur form T is required; // * = .FALSE.: only eigenvalues are required. // * // * WANTZ (input) LOGICAL // * = .TRUE. : the matrix of Schur vectors Z is required; // * = .FALSE.: Schur vectors are not required. // * // * N (input) INTEGER // * The order of the matrix H. N .GE. 0. // * // * ILO (input) INTEGER // * IHI (input) INTEGER // * It is assumed that H is already upper triangular in rows // * and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, // * H(ILO,ILO-1) is zero. ILO and IHI are normally set by a // * previous call to DGEBAL, and then passed to DGEHRD when the // * matrix output by DGEBAL is reduced to Hessenberg form. // * Otherwise, ILO and IHI should be set to 1 and N, // * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. // * If N = 0, then ILO = 1 and IHI = 0. // * // * H (input/output) DOUBLE PRECISION array, dimension (LDH,N) // * On entry, the upper Hessenberg matrix H. // * On exit, if INFO = 0 and WANTT is .TRUE., then H contains // * the upper quasi-triangular matrix T from the Schur // * decomposition (the Schur form); 2-by-2 diagonal blocks // * (corresponding to complex conjugate pairs of eigenvalues) // * are returned in standard form, with H(i,i) = H(i+1,i+1) // * and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is // * .FALSE., then the contents of H are unspecified on exit. // * (The output value of H when INFO.GT.0 is given under the // * description of INFO below.) // * // * This subroutine may explicitly set H(i,j) = 0 for i.GT.j and // * j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. // * // * LDH (input) INTEGER // * The leading dimension of the array H. LDH .GE. max(1,N). // * // * WR (output) DOUBLE PRECISION array, dimension (IHI) // * WI (output) DOUBLE PRECISION array, dimension (IHI) // * The real and imaginary parts, respectively, of the computed // * eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI) // * and WI(ILO:IHI). If two eigenvalues are computed as a // * complex conjugate pair, they are stored in consecutive // * elements of WR and WI, say the i-th and (i+1)th, with // * WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then // * the eigenvalues are stored in the same order as on the // * diagonal of the Schur form returned in H, with // * WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal // * block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and // * WI(i+1) = -WI(i). // * // * ILOZ (input) INTEGER // * IHIZ (input) INTEGER // * Specify the rows of Z to which transformations must be // * applied if WANTZ is .TRUE.. // * 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. // * // * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) // * If WANTZ is .FALSE., then Z is not referenced. // * If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is // * replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the // * orthogonal Schur factor of H(ILO:IHI,ILO:IHI). // * (The output value of Z when INFO.GT.0 is given under // * the description of INFO below.) // * // * LDZ (input) INTEGER // * The leading dimension of the array Z. if WANTZ is .TRUE. // * then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. // * // * WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK // * On exit, if LWORK = -1, WORK(1) returns an estimate of // * the optimal value for LWORK. // * // * LWORK (input) INTEGER // * The dimension of the array WORK. LWORK .GE. max(1,N) // * is sufficient, but LWORK typically as large as 6*N may // * be required for optimal performance. A workspace query // * to determine the optimal workspace size is recommended. // * // * If LWORK = -1, then DLAQR0 does a workspace query. // * In this case, DLAQR0 checks the input parameters and // * estimates the optimal workspace size for the given // * values of N, ILO and IHI. The estimate is returned // * in WORK(1). No error message related to LWORK is // * issued by XERBLA. Neither H nor Z are accessed. // * // * // * INFO (output) INTEGER // * = 0: successful exit // * .GT. 0: if INFO = i, DLAQR0 failed to compute all of // * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR // * and WI contain those eigenvalues which have been // * successfully computed. (Failures are rare.) // * // * If INFO .GT. 0 and WANT is .FALSE., then on exit, // * the remaining unconverged eigenvalues are the eigen- // * values of the upper Hessenberg matrix rows and // * columns ILO through INFO of the final, output // * value of H. // * // * If INFO .GT. 0 and WANTT is .TRUE., then on exit // * // * (*) (initial value of H)*U = U*(final value of H) // * // * where U is an orthogonal matrix. The final // * value of H is upper Hessenberg and quasi-triangular // * in rows and columns INFO+1 through IHI. // * // * If INFO .GT. 0 and WANTZ is .TRUE., then on exit // * // * (final value of Z(ILO:IHI,ILOZ:IHIZ) // * = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U // * // * where U is the orthogonal matrix in (*) (regard- // * less of the value of WANTT.) // * // * If INFO .GT. 0 and WANTZ is .FALSE., then Z is not // * accessed. // * // * // * ================================================================ // * Based on contributions by // * Karen Braman and Ralph Byers, Department of Mathematics, // * University of Kansas, USA // * // * ================================================================ // * // * References: // * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR // * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 // * Performance, SIAM Journal of Matrix Analysis, volume 23, pages // * 929--947, 2002. // * // * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR // * Algorithm Part II: Aggressive Early Deflation, SIAM Journal // * of Matrix Analysis, volume 23, pages 948--973, 2002. // * // * ================================================================ // * .. Parameters .. // * // * ==== Matrices of order NTINY or smaller must be processed by // * . DLAHQR because of insufficient subdiagonal scratch space. // * . (This is a hard limit.) ==== // * // * ==== Exceptional deflation windows: try to cure rare // * . slow convergence by increasing the size of the // * . deflation window after KEXNW iterations. ===== // * // * ==== Exceptional shifts: try to cure rare slow convergence // * . with ad-hoc exceptional shifts every KEXSH iterations. // * . The constants WILK1 and WILK2 are used to form the // * . exceptional shifts. ==== // * // * .. // * .. Local Scalars .. // * .. // * .. External Functions .. // * .. // * .. Local Arrays .. // * .. // * .. External Subroutines .. // * .. // * .. Intrinsic Functions .. // INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD; // * .. // * .. Executable Statements .. #endregion #region Body INFO = 0; // * // * ==== Quick return for N = 0: nothing to do. ==== // * if (N == 0) { WORK[1 + o_work] = ONE; return; } // * // * ==== Set up job flags for ILAENV. ==== // * if (WANTT) { FortranLib.Copy(ref JBCMPZ, 1, 1, "S"); } else { FortranLib.Copy(ref JBCMPZ, 1, 1, "E"); } if (WANTZ) { FortranLib.Copy(ref JBCMPZ, 2, 2, "V"); } else { FortranLib.Copy(ref JBCMPZ, 2, 2, "N"); } // * // * ==== Tiny matrices must use DLAHQR. ==== // * if (N <= NTINY) { // * // * ==== Estimate optimal workspace. ==== // * LWKOPT = 1; if (LWORK != -1) { this._dlahqr.Run(WANTT, WANTZ, N, ILO, IHI, ref H, offset_h , LDH, ref WR, offset_wr, ref WI, offset_wi, ILOZ, IHIZ, ref Z, offset_z , LDZ, ref INFO); } } else { // * // * ==== Use small bulge multi-shift QR with aggressive early // * . deflation on larger-than-tiny matrices. ==== // * // * ==== Hope for the best. ==== // * INFO = 0; // * // * ==== NWR = recommended deflation window size. At this // * . point, N .GT. NTINY = 11, so there is enough // * . subdiagonal workspace for NWR.GE.2 as required. // * . (In fact, there is enough subdiagonal space for // * . NWR.GE.3.) ==== // * NWR = this._ilaenv.Run(13, "DLAQR0", JBCMPZ, N, ILO, IHI, LWORK); NWR = Math.Max(2, NWR); NWR = Math.Min(IHI - ILO + 1, Math.Min((N - 1) / 3, NWR)); NW = NWR; // * // * ==== NSR = recommended number of simultaneous shifts. // * . At this point N .GT. NTINY = 11, so there is at // * . enough subdiagonal workspace for NSR to be even // * . and greater than or equal to two as required. ==== // * NSR = this._ilaenv.Run(15, "DLAQR0", JBCMPZ, N, ILO, IHI, LWORK); NSR = Math.Min(NSR, Math.Min((N + 6) / 9, IHI - ILO)); NSR = Math.Max(2, NSR - FortranLib.Mod(NSR, 2)); // * // * ==== Estimate optimal workspace ==== // * // * ==== Workspace query call to DLAQR3 ==== // * this._dlaqr3.Run(WANTT, WANTZ, N, ILO, IHI, NWR + 1 , ref H, offset_h, LDH, ILOZ, IHIZ, ref Z, offset_z, LDZ , ref LS, ref LD, ref WR, offset_wr, ref WI, offset_wi, ref H, offset_h, LDH , N, ref H, offset_h, LDH, N, ref H, offset_h, LDH , ref WORK, offset_work, -1); // * // * ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ==== // * LWKOPT = Math.Max(3 * NSR / 2, Convert.ToInt32(Math.Truncate(WORK[1 + o_work]))); // * // * ==== Quick return in case of workspace query. ==== // * if (LWORK == -1) { WORK[1 + o_work] = Convert.ToDouble(LWKOPT); return; } // * // * ==== DLAHQR/DLAQR0 crossover point ==== // * NMIN = this._ilaenv.Run(12, "DLAQR0", JBCMPZ, N, ILO, IHI, LWORK); NMIN = Math.Max(NTINY, NMIN); // * // * ==== Nibble crossover point ==== // * NIBBLE = this._ilaenv.Run(14, "DLAQR0", JBCMPZ, N, ILO, IHI, LWORK); NIBBLE = Math.Max(0, NIBBLE); // * // * ==== Accumulate reflections during ttswp? Use block // * . 2-by-2 structure during matrix-matrix multiply? ==== // * KACC22 = this._ilaenv.Run(16, "DLAQR0", JBCMPZ, N, ILO, IHI, LWORK); KACC22 = Math.Max(0, KACC22); KACC22 = Math.Min(2, KACC22); // * // * ==== NWMAX = the largest possible deflation window for // * . which there is sufficient workspace. ==== // * NWMAX = Math.Min((N - 1) / 3, LWORK / 2); // * // * ==== NSMAX = the Largest number of simultaneous shifts // * . for which there is sufficient workspace. ==== // * NSMAX = Math.Min((N + 6) / 9, 2 * LWORK / 3); NSMAX -= FortranLib.Mod(NSMAX, 2); // * // * ==== NDFL: an iteration count restarted at deflation. ==== // * NDFL = 1; // * // * ==== ITMAX = iteration limit ==== // * ITMAX = Math.Max(30, 2 * KEXSH) * Math.Max(10, (IHI - ILO + 1)); // * // * ==== Last row and column in the active block ==== // * KBOT = IHI; // * // * ==== Main Loop ==== // * for (IT = 1; IT <= ITMAX; IT++) { // * // * ==== Done when KBOT falls below ILO ==== // * if (KBOT < ILO) { goto LABEL90; } // * // * ==== Locate active block ==== // * for (K = KBOT; K >= ILO + 1; K += -1) { if (H[K + (K - 1) * LDH + o_h] == ZERO) { goto LABEL20; } } K = ILO; LABEL20 :; KTOP = K; // * // * ==== Select deflation window size ==== // * NH = KBOT - KTOP + 1; if (NDFL < KEXNW || NH < NW) { // * // * ==== Typical deflation window. If possible and // * . advisable, nibble the entire active block. // * . If not, use size NWR or NWR+1 depending upon // * . which has the smaller corresponding subdiagonal // * . entry (a heuristic). ==== // * NWINC = true; if (NH <= Math.Min(NMIN, NWMAX)) { NW = NH; } else { NW = Math.Min(NWR, Math.Min(NH, NWMAX)); if (NW < NWMAX) { if (NW >= NH - 1) { NW = NH; } else { KWTOP = KBOT - NW + 1; if (Math.Abs(H[KWTOP + (KWTOP - 1) * LDH + o_h]) > Math.Abs(H[KWTOP - 1 + (KWTOP - 2) * LDH + o_h])) { NW += 1; } } } } } else { // * // * ==== Exceptional deflation window. If there have // * . been no deflations in KEXNW or more iterations, // * . then vary the deflation window size. At first, // * . because, larger windows are, in general, more // * . powerful than smaller ones, rapidly increase the // * . window up to the maximum reasonable and possible. // * . Then maybe try a slightly smaller window. ==== // * if (NWINC && NW < Math.Min(NWMAX, NH)) { NW = Math.Min(NWMAX, Math.Min(NH, 2 * NW)); } else { NWINC = false; if (NW == NH && NH > 2) { NW = NH - 1; } } } // * // * ==== Aggressive early deflation: // * . split workspace under the subdiagonal into // * . - an nw-by-nw work array V in the lower // * . left-hand-corner, // * . - an NW-by-at-least-NW-but-more-is-better // * . (NW-by-NHO) horizontal work array along // * . the bottom edge, // * . - an at-least-NW-but-more-is-better (NHV-by-NW) // * . vertical work array along the left-hand-edge. // * . ==== // * KV = N - NW + 1; KT = NW + 1; NHO = (N - NW - 1) - KT + 1; KWV = NW + 2; NVE = (N - NW) - KWV + 1; // * // * ==== Aggressive early deflation ==== // * this._dlaqr3.Run(WANTT, WANTZ, N, KTOP, KBOT, NW , ref H, offset_h, LDH, ILOZ, IHIZ, ref Z, offset_z, LDZ , ref LS, ref LD, ref WR, offset_wr, ref WI, offset_wi, ref H, KV + 1 * LDH + o_h, LDH , NHO, ref H, KV + KT * LDH + o_h, LDH, NVE, ref H, KWV + 1 * LDH + o_h, LDH , ref WORK, offset_work, LWORK); // * // * ==== Adjust KBOT accounting for new deflations. ==== // * KBOT -= LD; // * // * ==== KS points to the shifts. ==== // * KS = KBOT - LS + 1; // * // * ==== Skip an expensive QR sweep if there is a (partly // * . heuristic) reason to expect that many eigenvalues // * . will deflate without it. Here, the QR sweep is // * . skipped if many eigenvalues have just been deflated // * . or if the remaining active block is small. // * if ((LD == 0) || ((100 * LD <= NW * NIBBLE) && (KBOT - KTOP + 1 > Math.Min(NMIN, NWMAX)))) { // * // * ==== NS = nominal number of simultaneous shifts. // * . This may be lowered (slightly) if DLAQR3 // * . did not provide that many shifts. ==== // * NS = Math.Min(NSMAX, Math.Min(NSR, Math.Max(2, KBOT - KTOP))); NS -= FortranLib.Mod(NS, 2); // * // * ==== If there have been no deflations // * . in a multiple of KEXSH iterations, // * . then try exceptional shifts. // * . Otherwise use shifts provided by // * . DLAQR3 above or from the eigenvalues // * . of a trailing principal submatrix. ==== // * if (FortranLib.Mod(NDFL, KEXSH) == 0) { KS = KBOT - NS + 1; for (I = KBOT; I >= Math.Max(KS + 1, KTOP + 2); I += -2) { SS = Math.Abs(H[I + (I - 1) * LDH + o_h]) + Math.Abs(H[I - 1 + (I - 2) * LDH + o_h]); AA = WILK1 * SS + H[I + I * LDH + o_h]; BB = SS; CC = WILK2 * SS; DD = AA; this._dlanv2.Run(ref AA, ref BB, ref CC, ref DD, ref WR[I - 1 + o_wr], ref WI[I - 1 + o_wi] , ref WR[I + o_wr], ref WI[I + o_wi], ref CS, ref SN); } if (KS == KTOP) { WR[KS + 1 + o_wr] = H[KS + 1 + (KS + 1) * LDH + o_h]; WI[KS + 1 + o_wi] = ZERO; WR[KS + o_wr] = WR[KS + 1 + o_wr]; WI[KS + o_wi] = WI[KS + 1 + o_wi]; } } else { // * // * ==== Got NS/2 or fewer shifts? Use DLAQR4 or // * . DLAHQR on a trailing principal submatrix to // * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, // * . there is enough space below the subdiagonal // * . to fit an NS-by-NS scratch array.) ==== // * if (KBOT - KS + 1 <= NS / 2) { KS = KBOT - NS + 1; KT = N - NS + 1; this._dlacpy.Run("A", NS, NS, H, KS + KS * LDH + o_h, LDH, ref H, KT + 1 * LDH + o_h , LDH); if (NS > NMIN) { this._dlaqr4.Run(false, false, NS, 1, NS, ref H, KT + 1 * LDH + o_h , LDH, ref WR, KS + o_wr, ref WI, KS + o_wi, 1, 1, ref ZDUM, offset_zdum , 1, ref WORK, offset_work, LWORK, ref INF); } else { this._dlahqr.Run(false, false, NS, 1, NS, ref H, KT + 1 * LDH + o_h , LDH, ref WR, KS + o_wr, ref WI, KS + o_wi, 1, 1, ref ZDUM, offset_zdum , 1, ref INF); } KS += INF; // * // * ==== In case of a rare QR failure use // * . eigenvalues of the trailing 2-by-2 // * . principal submatrix. ==== // * if (KS >= KBOT) { AA = H[KBOT - 1 + (KBOT - 1) * LDH + o_h]; CC = H[KBOT + (KBOT - 1) * LDH + o_h]; BB = H[KBOT - 1 + KBOT * LDH + o_h]; DD = H[KBOT + KBOT * LDH + o_h]; this._dlanv2.Run(ref AA, ref BB, ref CC, ref DD, ref WR[KBOT - 1 + o_wr], ref WI[KBOT - 1 + o_wi] , ref WR[KBOT + o_wr], ref WI[KBOT + o_wi], ref CS, ref SN); KS = KBOT - 1; } } // * if (KBOT - KS + 1 > NS) { // * // * ==== Sort the shifts (Helps a little) // * . Bubble sort keeps complex conjugate // * . pairs together. ==== // * SORTED = false; for (K = KBOT; K >= KS + 1; K += -1) { if (SORTED) { goto LABEL60; } SORTED = true; for (I = KS; I <= K - 1; I++) { if (Math.Abs(WR[I + o_wr]) + Math.Abs(WI[I + o_wi]) < Math.Abs(WR[I + 1 + o_wr]) + Math.Abs(WI[I + 1 + o_wi])) { SORTED = false; // * SWAP = WR[I + o_wr]; WR[I + o_wr] = WR[I + 1 + o_wr]; WR[I + 1 + o_wr] = SWAP; // * SWAP = WI[I + o_wi]; WI[I + o_wi] = WI[I + 1 + o_wi]; WI[I + 1 + o_wi] = SWAP; } } } LABEL60 :; } // * // * ==== Shuffle shifts into pairs of real shifts // * . and pairs of complex conjugate shifts // * . assuming complex conjugate shifts are // * . already adjacent to one another. (Yes, // * . they are.) ==== // * for (I = KBOT; I >= KS + 2; I += -2) { if (WI[I + o_wi] != -WI[I - 1 + o_wi]) { // * SWAP = WR[I + o_wr]; WR[I + o_wr] = WR[I - 1 + o_wr]; WR[I - 1 + o_wr] = WR[I - 2 + o_wr]; WR[I - 2 + o_wr] = SWAP; // * SWAP = WI[I + o_wi]; WI[I + o_wi] = WI[I - 1 + o_wi]; WI[I - 1 + o_wi] = WI[I - 2 + o_wi]; WI[I - 2 + o_wi] = SWAP; } } } // * // * ==== If there are only two shifts and both are // * . real, then use only one. ==== // * if (KBOT - KS + 1 == 2) { if (WI[KBOT + o_wi] == ZERO) { if (Math.Abs(WR[KBOT + o_wr] - H[KBOT + KBOT * LDH + o_h]) < Math.Abs(WR[KBOT - 1 + o_wr] - H[KBOT + KBOT * LDH + o_h])) { WR[KBOT - 1 + o_wr] = WR[KBOT + o_wr]; } else { WR[KBOT + o_wr] = WR[KBOT - 1 + o_wr]; } } } // * // * ==== Use up to NS of the the smallest magnatiude // * . shifts. If there aren't NS shifts available, // * . then use them all, possibly dropping one to // * . make the number of shifts even. ==== // * NS = Math.Min(NS, KBOT - KS + 1); NS -= FortranLib.Mod(NS, 2); KS = KBOT - NS + 1; // * // * ==== Small-bulge multi-shift QR sweep: // * . split workspace under the subdiagonal into // * . - a KDU-by-KDU work array U in the lower // * . left-hand-corner, // * . - a KDU-by-at-least-KDU-but-more-is-better // * . (KDU-by-NHo) horizontal work array WH along // * . the bottom edge, // * . - and an at-least-KDU-but-more-is-better-by-KDU // * . (NVE-by-KDU) vertical work WV arrow along // * . the left-hand-edge. ==== // * KDU = 3 * NS - 3; KU = N - KDU + 1; KWH = KDU + 1; NHO = (N - KDU + 1 - 4) - (KDU + 1) + 1; KWV = KDU + 4; NVE = N - KDU - KWV + 1; // * // * ==== Small-bulge multi-shift QR sweep ==== // * this._dlaqr5.Run(WANTT, WANTZ, KACC22, N, KTOP, KBOT , NS, ref WR, KS + o_wr, ref WI, KS + o_wi, ref H, offset_h, LDH, ILOZ , IHIZ, ref Z, offset_z, LDZ, ref WORK, offset_work, 3, ref H, KU + 1 * LDH + o_h , LDH, NVE, ref H, KWV + 1 * LDH + o_h, LDH, NHO, ref H, KU + KWH * LDH + o_h , LDH); } // * // * ==== Note progress (or the lack of it). ==== // * if (LD > 0) { NDFL = 1; } else { NDFL += 1; } // * // * ==== End of main loop ==== } // * // * ==== Iteration limit exceeded. Set INFO to show where // * . the problem occurred and exit. ==== // * INFO = KBOT; LABEL90 :; } // * // * ==== Return the optimal value of LWORK. ==== // * WORK[1 + o_work] = Convert.ToDouble(LWKOPT); // * // * ==== End of DLAQR0 ==== // * #endregion }
public double Run(int N, IFAREN FCN, double X, double[] Y, int offset_y, double XEND, double POSNEG , double[] F0, int offset_f0, ref double[] F1, int offset_f1, ref double[] Y1, int offset_y1, int IORD, double HMAX, double[] ATOL, int offset_atol , double[] RTOL, int offset_rtol, int ITOL, double[] RPAR, int offset_rpar, int[] IPAR, int offset_ipar) { double hinit = 0; #region Implicit Variables double DNF = 0; double DNY = 0; double ATOLI = 0; double RTOLI = 0; double SK = 0; int I = 0; double H = 0; double DER2 = 0; double DER12 = 0; double H1 = 0; #endregion #region Array Index Correction int o_y = -1 + offset_y; int o_f0 = -1 + offset_f0; int o_f1 = -1 + offset_f1; int o_y1 = -1 + offset_y1; int o_atol = -1 + offset_atol; int o_rtol = -1 + offset_rtol; int o_rpar = -1 + offset_rpar; int o_ipar = -1 + offset_ipar; #endregion // C ---------------------------------------------------------- // C ---- COMPUTATION OF AN INITIAL STEP SIZE GUESS // C ---------------------------------------------------------- // C ---- COMPUTE A FIRST GUESS FOR EXPLICIT EULER AS // C ---- H = 0.01 * NORM (Y0) / NORM (F0) // C ---- THE INCREMENT FOR EXPLICIT EULER IS SMALL // C ---- COMPARED TO THE SOLUTION #region Body DNF = 0.0E0; DNY = 0.0E0; ATOLI = ATOL[1 + o_atol]; RTOLI = RTOL[1 + o_rtol]; if (ITOL == 0) { for (I = 1; I <= N; I++) { SK = ATOLI + RTOLI * Math.Abs(Y[I + o_y]); DNF += Math.Pow(F0[I + o_f0] / SK, 2); DNY += Math.Pow(Y[I + o_y] / SK, 2); } } else { for (I = 1; I <= N; I++) { SK = ATOL[I + o_atol] + RTOL[I + o_rtol] * Math.Abs(Y[I + o_y]); DNF += Math.Pow(F0[I + o_f0] / SK, 2); DNY += Math.Pow(Y[I + o_y] / SK, 2); } } if (DNF <= 1.0E-10 || DNY <= 1.0E-10) { H = 1.0E-6; } else { H = Math.Sqrt(DNY / DNF) * 0.01E0; } H = Math.Min(H, HMAX); H = FortranLib.Sign(H, POSNEG); // C ---- PERFORM AN EXPLICIT EULER STEP for (I = 1; I <= N; I++) { Y1[I + o_y1] = Y[I + o_y] + H * F0[I + o_f0]; } FCN.Run(N, X + H, Y1, offset_y1, ref F1, offset_f1, RPAR, offset_rpar, IPAR[1 + o_ipar]); // C ---- ESTIMATE THE SECOND DERIVATIVE OF THE SOLUTION DER2 = 0.0E0; if (ITOL == 0) { for (I = 1; I <= N; I++) { SK = ATOLI + RTOLI * Math.Abs(Y[I + o_y]); DER2 += Math.Pow((F1[I + o_f1] - F0[I + o_f0]) / SK, 2); } } else { for (I = 1; I <= N; I++) { SK = ATOL[I + o_atol] + RTOL[I + o_rtol] * Math.Abs(Y[I + o_y]); DER2 += Math.Pow((F1[I + o_f1] - F0[I + o_f0]) / SK, 2); } } DER2 = Math.Sqrt(DER2) / H; // C ---- STEP SIZE IS COMPUTED SUCH THAT // C ---- H**IORD * MAX ( NORM (F0), NORM (DER2)) = 0.01 DER12 = Math.Max(Math.Abs(DER2), Math.Sqrt(DNF)); if (DER12 <= 1.0E-15) { H1 = Math.Max(1.0E-6, Math.Abs(H) * 1.0E-3); } else { H1 = Math.Pow(0.01E0 / DER12, 1.0E0 / IORD); } H = Math.Min(100 * Math.Abs(H), Math.Min(H1, HMAX)); hinit = FortranLib.Sign(H, POSNEG); return(hinit); #endregion }
public double Run(int N, double[] DX, int offset_dx, int INCX, double[] DY, int offset_dy, int INCY) { double ddot = 0; #region Variables double DTEMP = 0; int I = 0; int IX = 0; int IY = 0; int M = 0; int MP1 = 0; #endregion #region Array Index Correction int o_dx = -1 + offset_dx; int o_dy = -1 + offset_dy; #endregion // c // c forms the dot product of two vectors. // c uses unrolled loops for increments equal to one. // c jack dongarra, linpack, 3/11/78. // c // c #region Body ddot = 0.0E0; DTEMP = 0.0E0; if (N <= 0) { return(ddot); } if (INCX == 1 && INCY == 1) { goto LABEL20; } // c // c code for unequal increments or equal increments // c not equal to 1 // c IX = 1; IY = 1; if (INCX < 0) { IX = (-N + 1) * INCX + 1; } if (INCY < 0) { IY = (-N + 1) * INCY + 1; } for (I = 1; I <= N; I++) { DTEMP += DX[IX + o_dx] * DY[IY + o_dy]; IX += INCX; IY += INCY; } ddot = DTEMP; return(ddot); // c // c code for both increments equal to 1 // c // c // c clean-up loop // c LABEL20 : M = FortranLib.Mod(N, 5); if (M == 0) { goto LABEL40; } for (I = 1; I <= M; I++) { DTEMP += DX[I + o_dx] * DY[I + o_dy]; } if (N < 5) { goto LABEL60; } LABEL40 : MP1 = M + 1; for (I = MP1; I <= N; I += 5) { DTEMP += DX[I + o_dx] * DY[I + o_dy] + DX[I + 1 + o_dx] * DY[I + 1 + o_dy] + DX[I + 2 + o_dx] * DY[I + 2 + o_dy] + DX[I + 3 + o_dx] * DY[I + 3 + o_dy] + DX[I + 4 + o_dx] * DY[I + 4 + o_dy]; } LABEL60 : ddot = DTEMP; return(ddot); #endregion }
public void Run(int N, double DA, double[] DX, int offset_dx, int INCX, ref double[] DY, int offset_dy, int INCY) { #region Variables int I = 0; int IX = 0; int IY = 0; int M = 0; int MP1 = 0; #endregion #region Array Index Correction int o_dx = -1 + offset_dx; int o_dy = -1 + offset_dy; #endregion // c // c constant times a vector plus a vector. // c uses unrolled loops for increments equal to one. // c jack dongarra, linpack, 3/11/78. // c // c #region Body if (N <= 0) { return; } if (DA == 0.0E0) { return; } if (INCX == 1 && INCY == 1) { goto LABEL20; } // c // c code for unequal increments or equal increments // c not equal to 1 // c IX = 1; IY = 1; if (INCX < 0) { IX = (-N + 1) * INCX + 1; } if (INCY < 0) { IY = (-N + 1) * INCY + 1; } for (I = 1; I <= N; I++) { DY[IY + o_dy] += DA * DX[IX + o_dx]; IX += INCX; IY += INCY; } return; // c // c code for both increments equal to 1 // c // c // c clean-up loop // c LABEL20 : M = FortranLib.Mod(N, 4); if (M == 0) { goto LABEL40; } for (I = 1; I <= M; I++) { DY[I + o_dy] += DA * DX[I + o_dx]; } if (N < 4) { return; } LABEL40 : MP1 = M + 1; for (I = MP1; I <= N; I += 4) { DY[I + o_dy] += DA * DX[I + o_dx]; DY[I + 1 + o_dy] += DA * DX[I + 1 + o_dx]; DY[I + 2 + o_dy] += DA * DX[I + 2 + o_dx]; DY[I + 3 + o_dy] += DA * DX[I + 3 + o_dx]; } return; #endregion }
/// <summary> /// Purpose /// ======= /// /// ILAENV is called from the LAPACK routines to choose problem-dependent /// parameters for the local environment. See ISPEC for a description of /// the parameters. /// /// ILAENV returns an INTEGER /// if ILAENV .GE. 0: ILAENV returns the value of the parameter specified by ISPEC /// if ILAENV .LT. 0: if ILAENV = -k, the k-th argument had an illegal value. /// /// This version provides a set of parameters which should give good, /// but not optimal, performance on many of the currently available /// computers. Users are encouraged to modify this subroutine to set /// the tuning parameters for their particular machine using the option /// and problem size information in the arguments. /// /// This routine will not function correctly if it is converted to all /// lower case. Converting it to all upper case is allowed. /// ///</summary> /// <param name="ISPEC"> /// (input) INTEGER /// Specifies the parameter to be returned as the value of /// ILAENV. /// = 1: the optimal blocksize; if this value is 1, an unblocked /// algorithm will give the best performance. /// = 2: the minimum block size for which the block routine /// should be used; if the usable block size is less than /// this value, an unblocked routine should be used. /// = 3: the crossover point (in a block routine, for N less /// than this value, an unblocked routine should be used) /// = 4: the number of shifts, used in the nonsymmetric /// eigenvalue routines (DEPRECATED) /// = 5: the minimum column dimension for blocking to be used; /// rectangular blocks must have dimension at least k by m, /// where k is given by ILAENV(2,...) and m by ILAENV(5,...) /// = 6: the crossover point for the SVD (when reducing an m by n /// matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds /// this value, a QR factorization is used first to reduce /// the matrix to a triangular form.) /// = 7: the number of processors /// = 8: the crossover point for the multishift QR method /// for nonsymmetric eigenvalue problems (DEPRECATED) /// = 9: maximum size of the subproblems at the bottom of the /// computation tree in the divide-and-conquer algorithm /// (used by xGELSD and xGESDD) /// =10: ieee NaN arithmetic can be trusted not to trap /// =11: infinity arithmetic can be trusted not to trap /// 12 .LE. ISPEC .LE. 16: /// xHSEQR or one of its subroutines, /// see IPARMQ for detailed explanation ///</param> /// <param name="NAME"> /// (input) CHARACTER*(*) /// The name of the calling subroutine, in either upper case or /// lower case. ///</param> /// <param name="OPTS"> /// (input) CHARACTER*(*) /// The character options to the subroutine NAME, concatenated /// into a single character string. For example, UPLO = 'U', /// TRANS = 'T', and DIAG = 'N' for a triangular routine would /// be specified as OPTS = 'UTN'. ///</param> /// <param name="N1"> /// (input) INTEGER ///</param> /// <param name="N2"> /// (input) INTEGER ///</param> /// <param name="N3"> /// (input) INTEGER ///</param> /// <param name="N4"> /// (input) INTEGER /// Problem dimensions for the subroutine NAME; these may not all /// be required. ///</param> public int Run(int ISPEC, string NAME, string OPTS, int N1, int N2, int N3 , int N4) { int ilaenv = 0; #region Variables int I = 0; int IC = 0; int IZ = 0; int NB = 0; int NBMIN = 0; int NX = 0; bool CNAME = false; bool SNAME = false; string C1 = new string(' ', 1); string C2 = new string(' ', 2); string C4 = new string(' ', 2); string C3 = new string(' ', 3); string SUBNAM = new string(' ', 6); #endregion #region Prolog // * // * -- LAPACK auxiliary routine (version 3.1.1) -- // * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. // * January 2007 // * // * .. Scalar Arguments .. // * .. // * // * Purpose // * ======= // * // * ILAENV is called from the LAPACK routines to choose problem-dependent // * parameters for the local environment. See ISPEC for a description of // * the parameters. // * // * ILAENV returns an INTEGER // * if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC // * if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. // * // * This version provides a set of parameters which should give good, // * but not optimal, performance on many of the currently available // * computers. Users are encouraged to modify this subroutine to set // * the tuning parameters for their particular machine using the option // * and problem size information in the arguments. // * // * This routine will not function correctly if it is converted to all // * lower case. Converting it to all upper case is allowed. // * // * Arguments // * ========= // * // * ISPEC (input) INTEGER // * Specifies the parameter to be returned as the value of // * ILAENV. // * = 1: the optimal blocksize; if this value is 1, an unblocked // * algorithm will give the best performance. // * = 2: the minimum block size for which the block routine // * should be used; if the usable block size is less than // * this value, an unblocked routine should be used. // * = 3: the crossover point (in a block routine, for N less // * than this value, an unblocked routine should be used) // * = 4: the number of shifts, used in the nonsymmetric // * eigenvalue routines (DEPRECATED) // * = 5: the minimum column dimension for blocking to be used; // * rectangular blocks must have dimension at least k by m, // * where k is given by ILAENV(2,...) and m by ILAENV(5,...) // * = 6: the crossover point for the SVD (when reducing an m by n // * matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds // * this value, a QR factorization is used first to reduce // * the matrix to a triangular form.) // * = 7: the number of processors // * = 8: the crossover point for the multishift QR method // * for nonsymmetric eigenvalue problems (DEPRECATED) // * = 9: maximum size of the subproblems at the bottom of the // * computation tree in the divide-and-conquer algorithm // * (used by xGELSD and xGESDD) // * =10: ieee NaN arithmetic can be trusted not to trap // * =11: infinity arithmetic can be trusted not to trap // * 12 <= ISPEC <= 16: // * xHSEQR or one of its subroutines, // * see IPARMQ for detailed explanation // * // * NAME (input) CHARACTER*(*) // * The name of the calling subroutine, in either upper case or // * lower case. // * // * OPTS (input) CHARACTER*(*) // * The character options to the subroutine NAME, concatenated // * into a single character string. For example, UPLO = 'U', // * TRANS = 'T', and DIAG = 'N' for a triangular routine would // * be specified as OPTS = 'UTN'. // * // * N1 (input) INTEGER // * N2 (input) INTEGER // * N3 (input) INTEGER // * N4 (input) INTEGER // * Problem dimensions for the subroutine NAME; these may not all // * be required. // * // * Further Details // * =============== // * // * The following conventions have been used when calling ILAENV from the // * LAPACK routines: // * 1) OPTS is a concatenation of all of the character options to // * subroutine NAME, in the same order that they appear in the // * argument list for NAME, even if they are not used in determining // * the value of the parameter specified by ISPEC. // * 2) The problem dimensions N1, N2, N3, N4 are specified in the order // * that they appear in the argument list for NAME. N1 is used // * first, N2 second, and so on, and unused problem dimensions are // * passed a value of -1. // * 3) The parameter value returned by ILAENV is checked for validity in // * the calling subroutine. For example, ILAENV is used to retrieve // * the optimal blocksize for STRTRI as follows: // * // * NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) // * IF( NB.LE.1 ) NB = MAX( 1, N ) // * // * ===================================================================== // * // * .. Local Scalars .. // * .. // * .. Intrinsic Functions .. // INTRINSIC CHAR, ICHAR, INT, MIN, REAL; // * .. // * .. External Functions .. // * .. // * .. Executable Statements .. // * #endregion #region Body switch (ISPEC) { case 1: goto LABEL10; case 2: goto LABEL10; case 3: goto LABEL10; case 4: goto LABEL80; case 5: goto LABEL90; case 6: goto LABEL100; case 7: goto LABEL110; case 8: goto LABEL120; case 9: goto LABEL130; case 10: goto LABEL140; case 11: goto LABEL150; case 12: goto LABEL160; case 13: goto LABEL160; case 14: goto LABEL160; case 15: goto LABEL160; case 16: goto LABEL160; } // * // * Invalid value for ISPEC // * ilaenv = -1; return(ilaenv); // * LABEL10 :; // * // * Convert NAME to upper case if the first character is lower case. // * ilaenv = 1; FortranLib.Copy(ref SUBNAM, NAME); IC = Convert.ToInt32(Convert.ToChar(FortranLib.Substring(SUBNAM, 1, 1))); IZ = Convert.ToInt32('Z'); if (IZ == 90 || IZ == 122) { // * // * ASCII character set // * if (IC >= 97 && IC <= 122) { FortranLib.Copy(ref SUBNAM, 1, 1, Convert.ToChar(IC - 32)); for (I = 2; I <= 6; I++) { IC = Convert.ToInt32(Convert.ToChar(FortranLib.Substring(SUBNAM, I, I))); if (IC >= 97 && IC <= 122) { FortranLib.Copy(ref SUBNAM, I, I, Convert.ToChar(IC - 32)); } } } // * } else { if (IZ == 233 || IZ == 169) { // * // * EBCDIC character set // * if ((IC >= 129 && IC <= 137) || (IC >= 145 && IC <= 153) || (IC >= 162 && IC <= 169)) { FortranLib.Copy(ref SUBNAM, 1, 1, Convert.ToChar(IC + 64)); for (I = 2; I <= 6; I++) { IC = Convert.ToInt32(Convert.ToChar(FortranLib.Substring(SUBNAM, I, I))); if ((IC >= 129 && IC <= 137) || (IC >= 145 && IC <= 153) || (IC >= 162 && IC <= 169)) { FortranLib.Copy(ref SUBNAM, I, I, Convert.ToChar(IC + 64)); } } } // * } else { if (IZ == 218 || IZ == 250) { // * // * Prime machines: ASCII+128 // * if (IC >= 225 && IC <= 250) { FortranLib.Copy(ref SUBNAM, 1, 1, Convert.ToChar(IC - 32)); for (I = 2; I <= 6; I++) { IC = Convert.ToInt32(Convert.ToChar(FortranLib.Substring(SUBNAM, I, I))); if (IC >= 225 && IC <= 250) { FortranLib.Copy(ref SUBNAM, I, I, Convert.ToChar(IC - 32)); } } } } } } // * FortranLib.Copy(ref C1, FortranLib.Substring(SUBNAM, 1, 1)); SNAME = C1 == "S" || C1 == "D"; CNAME = C1 == "C" || C1 == "Z"; if (!(CNAME || SNAME)) { return(ilaenv); } FortranLib.Copy(ref C2, FortranLib.Substring(SUBNAM, 2, 3)); FortranLib.Copy(ref C3, FortranLib.Substring(SUBNAM, 4, 6)); FortranLib.Copy(ref C4, FortranLib.Substring(C3, 2, 3)); // * switch (ISPEC) { case 1: goto LABEL50; case 2: goto LABEL60; case 3: goto LABEL70; } // * LABEL50 :; // * // * ISPEC = 1: block size // * // * In these examples, separate code is provided for setting NB for // * real and complex. We assume that NB will take the same value in // * single or double precision. // * NB = 1; // * if (C2 == "GE") { if (C3 == "TRF") { if (SNAME) { NB = 64; } else { NB = 64; } } else { if (C3 == "QRF" || C3 == "RQF" || C3 == "LQF" || C3 == "QLF") { if (SNAME) { NB = 32; } else { NB = 32; } } else { if (C3 == "HRD") { if (SNAME) { NB = 32; } else { NB = 32; } } else { if (C3 == "BRD") { if (SNAME) { NB = 32; } else { NB = 32; } } else { if (C3 == "TRI") { if (SNAME) { NB = 64; } else { NB = 64; } } } } } } } else { if (C2 == "PO") { if (C3 == "TRF") { if (SNAME) { NB = 64; } else { NB = 64; } } } else { if (C2 == "SY") { if (C3 == "TRF") { if (SNAME) { NB = 64; } else { NB = 64; } } else { if (SNAME && C3 == "TRD") { NB = 32; } else { if (SNAME && C3 == "GST") { NB = 64; } } } } else { if (CNAME && C2 == "HE") { if (C3 == "TRF") { NB = 64; } else { if (C3 == "TRD") { NB = 32; } else { if (C3 == "GST") { NB = 64; } } } } else { if (SNAME && C2 == "OR") { if (FortranLib.Substring(C3, 1, 1) == "G") { if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR") { NB = 32; } } else { if (FortranLib.Substring(C3, 1, 1) == "M") { if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR") { NB = 32; } } } } else { if (CNAME && C2 == "UN") { if (FortranLib.Substring(C3, 1, 1) == "G") { if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR") { NB = 32; } } else { if (FortranLib.Substring(C3, 1, 1) == "M") { if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR") { NB = 32; } } } } else { if (C2 == "GB") { if (C3 == "TRF") { if (SNAME) { if (N4 <= 64) { NB = 1; } else { NB = 32; } } else { if (N4 <= 64) { NB = 1; } else { NB = 32; } } } } else { if (C2 == "PB") { if (C3 == "TRF") { if (SNAME) { if (N2 <= 64) { NB = 1; } else { NB = 32; } } else { if (N2 <= 64) { NB = 1; } else { NB = 32; } } } } else { if (C2 == "TR") { if (C3 == "TRI") { if (SNAME) { NB = 64; } else { NB = 64; } } } else { if (C2 == "LA") { if (C3 == "UUM") { if (SNAME) { NB = 64; } else { NB = 64; } } } else { if (SNAME && C2 == "ST") { if (C3 == "EBZ") { NB = 1; } } } } } } } } } } } } ilaenv = NB; return(ilaenv); // * LABEL60 :; // * // * ISPEC = 2: minimum block size // * NBMIN = 2; if (C2 == "GE") { if (C3 == "QRF" || C3 == "RQF" || C3 == "LQF" || C3 == "QLF") { if (SNAME) { NBMIN = 2; } else { NBMIN = 2; } } else { if (C3 == "HRD") { if (SNAME) { NBMIN = 2; } else { NBMIN = 2; } } else { if (C3 == "BRD") { if (SNAME) { NBMIN = 2; } else { NBMIN = 2; } } else { if (C3 == "TRI") { if (SNAME) { NBMIN = 2; } else { NBMIN = 2; } } } } } } else { if (C2 == "SY") { if (C3 == "TRF") { if (SNAME) { NBMIN = 8; } else { NBMIN = 8; } } else { if (SNAME && C3 == "TRD") { NBMIN = 2; } } } else { if (CNAME && C2 == "HE") { if (C3 == "TRD") { NBMIN = 2; } } else { if (SNAME && C2 == "OR") { if (FortranLib.Substring(C3, 1, 1) == "G") { if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR") { NBMIN = 2; } } else { if (FortranLib.Substring(C3, 1, 1) == "M") { if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR") { NBMIN = 2; } } } } else { if (CNAME && C2 == "UN") { if (FortranLib.Substring(C3, 1, 1) == "G") { if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR") { NBMIN = 2; } } else { if (FortranLib.Substring(C3, 1, 1) == "M") { if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR") { NBMIN = 2; } } } } } } } } ilaenv = NBMIN; return(ilaenv); // * LABEL70 :; // * // * ISPEC = 3: crossover point // * NX = 0; if (C2 == "GE") { if (C3 == "QRF" || C3 == "RQF" || C3 == "LQF" || C3 == "QLF") { if (SNAME) { NX = 128; } else { NX = 128; } } else { if (C3 == "HRD") { if (SNAME) { NX = 128; } else { NX = 128; } } else { if (C3 == "BRD") { if (SNAME) { NX = 128; } else { NX = 128; } } } } } else { if (C2 == "SY") { if (SNAME && C3 == "TRD") { NX = 32; } } else { if (CNAME && C2 == "HE") { if (C3 == "TRD") { NX = 32; } } else { if (SNAME && C2 == "OR") { if (FortranLib.Substring(C3, 1, 1) == "G") { if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR") { NX = 128; } } } else { if (CNAME && C2 == "UN") { if (FortranLib.Substring(C3, 1, 1) == "G") { if (C4 == "QR" || C4 == "RQ" || C4 == "LQ" || C4 == "QL" || C4 == "HR" || C4 == "TR" || C4 == "BR") { NX = 128; } } } } } } } ilaenv = NX; return(ilaenv); // * LABEL80 :; // * // * ISPEC = 4: number of shifts (used by xHSEQR) // * ilaenv = 6; return(ilaenv); // * LABEL90 :; // * // * ISPEC = 5: minimum column dimension (not used) // * ilaenv = 2; return(ilaenv); // * LABEL100 :; // * // * ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) // * ilaenv = Convert.ToInt32(Math.Truncate(Convert.ToSingle(Math.Min(N1, N2)) * 1.6E0)); return(ilaenv); // * LABEL110 :; // * // * ISPEC = 7: number of processors (not used) // * ilaenv = 1; return(ilaenv); // * LABEL120 :; // * // * ISPEC = 8: crossover point for multishift (used by xHSEQR) // * ilaenv = 50; return(ilaenv); // * LABEL130 :; // * // * ISPEC = 9: maximum size of the subproblems at the bottom of the // * computation tree in the divide-and-conquer algorithm // * (used by xGELSD and xGESDD) // * ilaenv = 25; return(ilaenv); // * LABEL140 :; // * // * ISPEC = 10: ieee NaN arithmetic can be trusted not to trap // * // * ILAENV = 0 ilaenv = 1; if (ilaenv == 1) { ilaenv = this._ieeeck.Run(0, 0.0, 1.0); } return(ilaenv); // * LABEL150 :; // * // * ISPEC = 11: infinity arithmetic can be trusted not to trap // * // * ILAENV = 0 ilaenv = 1; if (ilaenv == 1) { ilaenv = this._ieeeck.Run(1, 0.0, 1.0); } return(ilaenv); // * LABEL160 :; // * // * 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. // * ilaenv = this._iparmq.Run(ISPEC, NAME, OPTS, N1, N2, N3, N4); return(ilaenv); // * // * End of ILAENV // * #endregion }
/// <summary> /// Purpose /// ======= /// * /// scales a vector by a constant. /// uses unrolled loops for increment equal to one. /// jack dongarra, linpack, 3/11/78. /// modified 3/93 to return if incx .le. 0. /// modified 12/3/93, array(1) declarations changed to array(*) ///</summary> public void Run(int N, double DA, ref double[] DX, int offset_dx, int INCX) { #region Variables int I = 0; int M = 0; int MP1 = 0; int NINCX = 0; #endregion #region Array Index Correction int o_dx = -1 + offset_dx; #endregion #region Prolog // * .. Scalar Arguments .. // * .. // * .. Array Arguments .. // * .. // * // * Purpose // * ======= // ** // * scales a vector by a constant. // * uses unrolled loops for increment equal to one. // * jack dongarra, linpack, 3/11/78. // * modified 3/93 to return if incx .le. 0. // * modified 12/3/93, array(1) declarations changed to array(*) // * // * // * .. Local Scalars .. // * .. // * .. Intrinsic Functions .. // INTRINSIC MOD; // * .. #endregion #region Body if (N <= 0 || INCX <= 0) { return; } if (INCX == 1) { goto LABEL20; } // * // * code for increment not equal to 1 // * NINCX = N * INCX; for (I = 1; (INCX >= 0) ? (I <= NINCX) : (I >= NINCX); I += INCX) { DX[I + o_dx] *= DA; } return; // * // * code for increment equal to 1 // * // * // * clean-up loop // * LABEL20 : M = FortranLib.Mod(N, 5); if (M == 0) { goto LABEL40; } for (I = 1; I <= M; I++) { DX[I + o_dx] *= DA; } if (N < 5) { return; } LABEL40 : MP1 = M + 1; for (I = MP1; I <= N; I += 5) { DX[I + o_dx] *= DA; DX[I + 1 + o_dx] *= DA; DX[I + 2 + o_dx] *= DA; DX[I + 3 + o_dx] *= DA; DX[I + 4 + o_dx] *= DA; } return; #endregion }
public void Run(int N, int M, ref double[] WS, int offset_ws, ref double[] WY, int offset_wy, ref double[] SY, int offset_sy, ref double[] SS, int offset_ss , double[] D, int offset_d, double[] R, int offset_r, ref int ITAIL, int IUPDAT, ref int COL, ref int HEAD , ref double THETA, double RR, double DR, double STP, double DTD) { #region Variables int J = 0; int POINTR = 0; double DDOT = 0; #endregion #region Implicit Variables int SS_COL = 0; #endregion #region Array Index Correction int o_ws = -1 - N + offset_ws; int o_wy = -1 - N + offset_wy; int o_sy = -1 - M + offset_sy; int o_ss = -1 - M + offset_ss; int o_d = -1 + offset_d; int o_r = -1 + offset_r; #endregion #region Prolog // c ************ // c // c Subroutine matupd // c // c This subroutine updates matrices WS and WY, and forms the // c middle matrix in B. // c // c Subprograms called: // c // c Linpack ... dcopy, ddot. // c // c // c * * * // c // c NEOS, November 1994. (Latest revision June 1996.) // c Optimization Technology Center. // c Argonne National Laboratory and Northwestern University. // c Written by // c Ciyou Zhu // c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. // c // c // c ************ // c Set pointers for matrices WS and WY. #endregion #region Body if (IUPDAT <= M) { COL = IUPDAT; ITAIL = FortranLib.Mod(HEAD + IUPDAT - 2, M) + 1; } else { ITAIL = FortranLib.Mod(ITAIL, M) + 1; HEAD = FortranLib.Mod(HEAD, M) + 1; } // c Update matrices WS and WY. this._dcopy.Run(N, D, offset_d, 1, ref WS, 1 + ITAIL * N + o_ws, 1); this._dcopy.Run(N, R, offset_r, 1, ref WY, 1 + ITAIL * N + o_wy, 1); // c Set theta=yy/ys. THETA = RR / DR; // c Form the middle matrix in B. // c update the upper triangle of SS, // c and the lower triangle of SY: if (IUPDAT > M) { // c move old information for (J = 1; J <= COL - 1; J++) { this._dcopy.Run(J, SS, 2 + (J + 1) * M + o_ss, 1, ref SS, 1 + J * M + o_ss, 1); this._dcopy.Run(COL - J, SY, J + 1 + (J + 1) * M + o_sy, 1, ref SY, J + J * M + o_sy, 1); } } // c add new information: the last row of SY // c and the last column of SS: POINTR = HEAD; SS_COL = COL * M + o_ss; for (J = 1; J <= COL - 1; J++) { SY[COL + J * M + o_sy] = this._ddot.Run(N, D, offset_d, 1, WY, 1 + POINTR * N + o_wy, 1); SS[J + SS_COL] = this._ddot.Run(N, WS, 1 + POINTR * N + o_ws, 1, D, offset_d, 1); POINTR = FortranLib.Mod(POINTR, M) + 1; } if (STP == ONE) { SS[COL + COL * M + o_ss] = DTD; } else { SS[COL + COL * M + o_ss] = STP * STP * DTD; } SY[COL + COL * M + o_sy] = DR; return; #endregion }
/// <param name="N"> /// is an integer variable. /// On entry n is the dimension of the problem. /// On exit n is unchanged. ///</param> /// <param name="M"> /// is an integer variable. /// On entry m is the maximum number of variable metric corrections /// used to define the limited memory matrix. /// On exit m is unchanged. ///</param> /// <param name="NSUB"> /// is an integer variable. /// On entry nsub is the number of free variables. /// On exit nsub is unchanged. ///</param> /// <param name="IND"> /// is an integer array of dimension nsub. /// On entry ind specifies the coordinate indices of free variables. /// On exit ind is unchanged. ///</param> /// <param name="L"> /// is a double precision array of dimension n. /// On entry l is the lower bound of x. /// On exit l is unchanged. ///</param> /// <param name="U"> /// is a double precision array of dimension n. /// On entry u is the upper bound of x. /// On exit u is unchanged. ///</param> /// <param name="NBD"> /// is a integer array of dimension n. /// On entry nbd represents the type of bounds imposed on the /// variables, and must be specified as follows: /// nbd(i)=0 if x(i) is unbounded, /// 1 if x(i) has only a lower bound, /// 2 if x(i) has both lower and upper bounds, and /// 3 if x(i) has only an upper bound. /// On exit nbd is unchanged. ///</param> /// <param name="X"> /// is a double precision array of dimension n. /// On entry x specifies the Cauchy point xcp. /// On exit x(i) is the minimizer of Q over the subspace of /// free variables. ///</param> /// <param name="D"> /// = -(Z'BZ)^(-1) r. /// /// The formula for the Newton direction, given the L-BFGS matrix /// and the Sherman-Morrison formula, is /// /// d = (1/theta)r + (1/theta*2) Z'WK^(-1)W'Z r. /// /// where /// K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] /// [L_a -R_z theta*S'AA'S ] /// /// Note that this procedure for computing d differs /// from that described in [1]. One can show that the matrix K is /// equal to the matrix M^[-1]N in that paper. /// /// n is an integer variable. /// On entry n is the dimension of the problem. /// On exit n is unchanged. /// /// m is an integer variable. /// On entry m is the maximum number of variable metric corrections /// used to define the limited memory matrix. /// On exit m is unchanged. /// /// nsub is an integer variable. /// On entry nsub is the number of free variables. /// On exit nsub is unchanged. /// /// ind is an integer array of dimension nsub. /// On entry ind specifies the coordinate indices of free variables. /// On exit ind is unchanged. /// /// l is a double precision array of dimension n. /// On entry l is the lower bound of x. /// On exit l is unchanged. /// /// u is a double precision array of dimension n. /// On entry u is the upper bound of x. /// On exit u is unchanged. /// /// nbd is a integer array of dimension n. /// On entry nbd represents the type of bounds imposed on the /// variables, and must be specified as follows: /// nbd(i)=0 if x(i) is unbounded, /// 1 if x(i) has only a lower bound, /// 2 if x(i) has both lower and upper bounds, and /// 3 if x(i) has only an upper bound. /// On exit nbd is unchanged. /// /// x is a double precision array of dimension n. /// On entry x specifies the Cauchy point xcp. /// On exit x(i) is the minimizer of Q over the subspace of /// free variables. /// /// d is a double precision array of dimension n. /// On entry d is the reduced gradient of Q at xcp. /// On exit d is the Newton direction of Q. /// /// ws and wy are double precision arrays; /// theta is a double precision variable; /// col is an integer variable; /// head is an integer variable. /// On entry they store the information defining the /// limited memory BFGS matrix: /// ws(n,m) stores S, a set of s-vectors; /// wy(n,m) stores Y, a set of y-vectors; /// theta is the scaling factor specifying B_0 = theta I; /// col is the number of variable metric corrections stored; /// head is the location of the 1st s- (or y-) vector in S (or Y). /// On exit they are unchanged. /// /// iword is an integer variable. /// On entry iword is unspecified. /// On exit iword specifies the status of the subspace solution. /// iword = 0 if the solution is in the box, /// 1 if some bound is encountered. /// /// wv is a double precision working array of dimension 2m. /// /// wn is a double precision array of dimension 2m x 2m. /// On entry the upper triangle of wn stores the LEL^T factorization /// of the indefinite matrix /// /// K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] /// [L_a -R_z theta*S'AA'S ] /// where E = [-I 0] /// [ 0 I] /// On exit wn is unchanged. /// /// iprint is an INTEGER variable that must be set by the user. /// It controls the frequency and type of output generated: /// iprint.LT.0 no output is generated; /// iprint=0 print only one line at the last iteration; /// 0.LT.iprint.LT.99 print also f and |proj g| every iprint iterations; /// iprint=99 print details of every iteration except n-vectors; /// iprint=100 print also the changes of active set and final x; /// iprint.GT.100 print details of every iteration including x and g; /// When iprint .GT. 0, the file iterate.dat will be created to /// summarize the iteration. /// /// info is an integer variable. /// On entry info is unspecified. /// On exit info = 0 for normal return, /// = nonzero for abnormal return /// when the matrix K is ill-conditioned. /// /// Subprograms called: /// /// Linpack dtrsl. /// /// /// References: /// /// [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited /// memory algorithm for bound constrained optimization'', /// SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. /// /// /// /// * * * /// /// NEOS, November 1994. (Latest revision June 1996.) /// Optimization Technology Center. /// Argonne National Laboratory and Northwestern University. /// Written by /// Ciyou Zhu /// in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. /// /// /// ************ /// /// /// /// /// ///</param> /// <param name="WS"> /// and wy are double precision arrays; ///</param> /// <param name="THETA"> /// is a double precision variable; ///</param> /// <param name="COL"> /// is an integer variable; ///</param> /// <param name="HEAD"> /// is an integer variable. /// On entry they store the information defining the /// limited memory BFGS matrix: /// ws(n,m) stores S, a set of s-vectors; /// wy(n,m) stores Y, a set of y-vectors; /// theta is the scaling factor specifying B_0 = theta I; /// col is the number of variable metric corrections stored; /// head is the location of the 1st s- (or y-) vector in S (or Y). /// On exit they are unchanged. ///</param> /// <param name="IWORD"> /// is an integer variable. /// On entry iword is unspecified. /// On exit iword specifies the status of the subspace solution. /// iword = 0 if the solution is in the box, /// 1 if some bound is encountered. ///</param> /// <param name="WV"> /// is a double precision working array of dimension 2m. ///</param> /// <param name="WN"> /// is a double precision array of dimension 2m x 2m. /// On entry the upper triangle of wn stores the LEL^T factorization /// of the indefinite matrix /// /// K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] /// [L_a -R_z theta*S'AA'S ] /// where E = [-I 0] /// [ 0 I] /// On exit wn is unchanged. ///</param> /// <param name="IPRINT"> /// is an INTEGER variable that must be set by the user. /// It controls the frequency and type of output generated: /// iprint.LT.0 no output is generated; /// iprint=0 print only one line at the last iteration; /// 0.LT.iprint.LT.99 print also f and |proj g| every iprint iterations; /// iprint=99 print details of every iteration except n-vectors; /// iprint=100 print also the changes of active set and final x; /// iprint.GT.100 print details of every iteration including x and g; /// When iprint .GT. 0, the file iterate.dat will be created to /// summarize the iteration. ///</param> /// <param name="INFO"> /// is an integer variable. /// On entry info is unspecified. /// On exit info = 0 for normal return, /// = nonzero for abnormal return /// when the matrix K is ill-conditioned. ///</param> public void Run(int N, int M, int NSUB, int[] IND, int offset_ind, double[] L, int offset_l, double[] U, int offset_u , int[] NBD, int offset_nbd, ref double[] X, int offset_x, ref double[] D, int offset_d, double[] WS, int offset_ws, double[] WY, int offset_wy, double THETA , int COL, int HEAD, ref int IWORD, ref double[] WV, int offset_wv, double[] WN, int offset_wn, int IPRINT , ref int INFO) { #region Variables int POINTR = 0; int M2 = 0; int COL2 = 0; int IBD = 0; int JY = 0; int JS = 0; int I = 0; int J = 0; int K = 0; double ALPHA = 0; double DK = 0; double TEMP1 = 0; double TEMP2 = 0; #endregion #region Array Index Correction int o_ind = -1 + offset_ind; int o_l = -1 + offset_l; int o_u = -1 + offset_u; int o_nbd = -1 + offset_nbd; int o_x = -1 + offset_x; int o_d = -1 + offset_d; int o_ws = -1 - N + offset_ws; int o_wy = -1 - N + offset_wy; int o_wv = -1 + offset_wv; int o_wn = -1 - (2 * M) + offset_wn; #endregion #region Prolog // c ************ // c // c Subroutine subsm // c // c Given xcp, l, u, r, an index set that specifies // c the active set at xcp, and an l-BFGS matrix B // c (in terms of WY, WS, SY, WT, head, col, and theta), // c this subroutine computes an approximate solution // c of the subspace problem // c // c (P) min Q(x) = r'(x-xcp) + 1/2 (x-xcp)' B (x-xcp) // c // c subject to l<=x<=u // c x_i=xcp_i for all i in A(xcp) // c // c along the subspace unconstrained Newton direction // c // c d = -(Z'BZ)^(-1) r. // c // c The formula for the Newton direction, given the L-BFGS matrix // c and the Sherman-Morrison formula, is // c // c d = (1/theta)r + (1/theta*2) Z'WK^(-1)W'Z r. // c // c where // c K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] // c [L_a -R_z theta*S'AA'S ] // c // c Note that this procedure for computing d differs // c from that described in [1]. One can show that the matrix K is // c equal to the matrix M^[-1]N in that paper. // c // c n is an integer variable. // c On entry n is the dimension of the problem. // c On exit n is unchanged. // c // c m is an integer variable. // c On entry m is the maximum number of variable metric corrections // c used to define the limited memory matrix. // c On exit m is unchanged. // c // c nsub is an integer variable. // c On entry nsub is the number of free variables. // c On exit nsub is unchanged. // c // c ind is an integer array of dimension nsub. // c On entry ind specifies the coordinate indices of free variables. // c On exit ind is unchanged. // c // c l is a double precision array of dimension n. // c On entry l is the lower bound of x. // c On exit l is unchanged. // c // c u is a double precision array of dimension n. // c On entry u is the upper bound of x. // c On exit u is unchanged. // c // c nbd is a integer array of dimension n. // c On entry nbd represents the type of bounds imposed on the // c variables, and must be specified as follows: // c nbd(i)=0 if x(i) is unbounded, // c 1 if x(i) has only a lower bound, // c 2 if x(i) has both lower and upper bounds, and // c 3 if x(i) has only an upper bound. // c On exit nbd is unchanged. // c // c x is a double precision array of dimension n. // c On entry x specifies the Cauchy point xcp. // c On exit x(i) is the minimizer of Q over the subspace of // c free variables. // c // c d is a double precision array of dimension n. // c On entry d is the reduced gradient of Q at xcp. // c On exit d is the Newton direction of Q. // c // c ws and wy are double precision arrays; // c theta is a double precision variable; // c col is an integer variable; // c head is an integer variable. // c On entry they store the information defining the // c limited memory BFGS matrix: // c ws(n,m) stores S, a set of s-vectors; // c wy(n,m) stores Y, a set of y-vectors; // c theta is the scaling factor specifying B_0 = theta I; // c col is the number of variable metric corrections stored; // c head is the location of the 1st s- (or y-) vector in S (or Y). // c On exit they are unchanged. // c // c iword is an integer variable. // c On entry iword is unspecified. // c On exit iword specifies the status of the subspace solution. // c iword = 0 if the solution is in the box, // c 1 if some bound is encountered. // c // c wv is a double precision working array of dimension 2m. // c // c wn is a double precision array of dimension 2m x 2m. // c On entry the upper triangle of wn stores the LEL^T factorization // c of the indefinite matrix // c // c K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] // c [L_a -R_z theta*S'AA'S ] // c where E = [-I 0] // c [ 0 I] // c On exit wn is unchanged. // c // c iprint is an INTEGER variable that must be set by the user. // c It controls the frequency and type of output generated: // c iprint<0 no output is generated; // c iprint=0 print only one line at the last iteration; // c 0<iprint<99 print also f and |proj g| every iprint iterations; // c iprint=99 print details of every iteration except n-vectors; // c iprint=100 print also the changes of active set and final x; // c iprint>100 print details of every iteration including x and g; // c When iprint > 0, the file iterate.dat will be created to // c summarize the iteration. // c // c info is an integer variable. // c On entry info is unspecified. // c On exit info = 0 for normal return, // c = nonzero for abnormal return // c when the matrix K is ill-conditioned. // c // c Subprograms called: // c // c Linpack dtrsl. // c // c // c References: // c // c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited // c memory algorithm for bound constrained optimization'', // c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. // c // c // c // c * * * // c // c NEOS, November 1994. (Latest revision June 1996.) // c Optimization Technology Center. // c Argonne National Laboratory and Northwestern University. // c Written by // c Ciyou Zhu // c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. // c // c // c ************ #endregion #region Body if (NSUB <= 0) { return; } if (IPRINT >= 99) { ; //ERROR-ERRORWRITE(6,1001) } // c Compute wv = W'Zd. POINTR = HEAD; for (I = 1; I <= COL; I++) { TEMP1 = ZERO; TEMP2 = ZERO; for (J = 1; J <= NSUB; J++) { K = IND[J + o_ind]; TEMP1 += WY[K + POINTR * N + o_wy] * D[J + o_d]; TEMP2 += WS[K + POINTR * N + o_ws] * D[J + o_d]; } WV[I + o_wv] = TEMP1; WV[COL + I + o_wv] = THETA * TEMP2; POINTR = FortranLib.Mod(POINTR, M) + 1; } // c Compute wv:=K^(-1)wv. M2 = 2 * M; COL2 = 2 * COL; this._dtrsl.Run(WN, offset_wn, M2, COL2, ref WV, offset_wv, 11, ref INFO); if (INFO != 0) { return; } for (I = 1; I <= COL; I++) { WV[I + o_wv] = -WV[I + o_wv]; } this._dtrsl.Run(WN, offset_wn, M2, COL2, ref WV, offset_wv, 01, ref INFO); if (INFO != 0) { return; } // c Compute d = (1/theta)d + (1/theta**2)Z'W wv. POINTR = HEAD; for (JY = 1; JY <= COL; JY++) { JS = COL + JY; for (I = 1; I <= NSUB; I++) { K = IND[I + o_ind]; D[I + o_d] += WY[K + POINTR * N + o_wy] * WV[JY + o_wv] / THETA + WS[K + POINTR * N + o_ws] * WV[JS + o_wv]; } POINTR = FortranLib.Mod(POINTR, M) + 1; } for (I = 1; I <= NSUB; I++) { D[I + o_d] /= THETA; } // c Backtrack to the feasible region. ALPHA = ONE; TEMP1 = ALPHA; for (I = 1; I <= NSUB; I++) { K = IND[I + o_ind]; DK = D[I + o_d]; if (NBD[K + o_nbd] != 0) { if (DK < ZERO && NBD[K + o_nbd] <= 2) { TEMP2 = L[K + o_l] - X[K + o_x]; if (TEMP2 >= ZERO) { TEMP1 = ZERO; } else { if (DK * ALPHA < TEMP2) { TEMP1 = TEMP2 / DK; } } } else { if (DK > ZERO && NBD[K + o_nbd] >= 2) { TEMP2 = U[K + o_u] - X[K + o_x]; if (TEMP2 <= ZERO) { TEMP1 = ZERO; } else { if (DK * ALPHA > TEMP2) { TEMP1 = TEMP2 / DK; } } } } if (TEMP1 < ALPHA) { ALPHA = TEMP1; IBD = I; } } } if (ALPHA < ONE) { DK = D[IBD + o_d]; K = IND[IBD + o_ind]; if (DK > ZERO) { X[K + o_x] = U[K + o_u]; D[IBD + o_d] = ZERO; } else { if (DK < ZERO) { X[K + o_x] = L[K + o_l]; D[IBD + o_d] = ZERO; } } } for (I = 1; I <= NSUB; I++) { K = IND[I + o_ind]; X[K + o_x] += ALPHA * D[I + o_d]; } if (IPRINT >= 99) { if (ALPHA < ONE) { //ERROR-ERROR WRITE (6,1002) ALPHA; } else { //ERROR-ERROR WRITE (6,*) 'SM solution inside the box'; } if (IPRINT > 100) { ; //ERROR-ERRORWRITE(6,1003)(X(I),I=1,N) } } if (ALPHA < ONE) { IWORD = 1; } else { IWORD = 0; } if (IPRINT >= 99) { ; //ERROR-ERRORWRITE(6,1004) } return; #endregion }
public void Run(int N, double DA, ref double[] DX, int offset_dx, int INCX) { #region Variables int I = 0; int M = 0; int MP1 = 0; int NINCX = 0; #endregion #region Array Index Correction int o_dx = -1 + offset_dx; #endregion // c // c scales a vector by a constant. // c uses unrolled loops for increment equal to one. // c jack dongarra, linpack, 3/11/78. // c modified 3/93 to return if incx .le. 0. // c // c #region Body if (N <= 0 || INCX <= 0) { return; } if (INCX == 1) { goto LABEL20; } // c // c code for increment not equal to 1 // c NINCX = N * INCX; for (I = 1; (INCX >= 0) ? (I <= NINCX) : (I >= NINCX); I += INCX) { DX[I + o_dx] *= DA; } return; // c // c code for increment equal to 1 // c // c // c clean-up loop // c LABEL20 : M = FortranLib.Mod(N, 5); if (M == 0) { goto LABEL40; } for (I = 1; I <= M; I++) { DX[I + o_dx] *= DA; } if (N < 5) { return; } LABEL40 : MP1 = M + 1; for (I = MP1; I <= N; I += 5) { DX[I + o_dx] *= DA; DX[I + 1 + o_dx] *= DA; DX[I + 2 + o_dx] *= DA; DX[I + 3 + o_dx] *= DA; DX[I + 4 + o_dx] *= DA; } return; #endregion }
/// <summary> /// Purpose /// ======= /// /// interchanges two vectors. /// uses unrolled loops for increments equal one. /// jack dongarra, linpack, 3/11/78. /// modified 12/3/93, array(1) declarations changed to array(*) ///</summary> public void Run(int N, ref double[] DX, int offset_dx, int INCX, ref double[] DY, int offset_dy, int INCY) { #region Variables double DTEMP = 0; int I = 0; int IX = 0; int IY = 0; int M = 0; int MP1 = 0; #endregion #region Array Index Correction int o_dx = -1 + offset_dx; int o_dy = -1 + offset_dy; #endregion #region Prolog // * .. Scalar Arguments .. // * .. // * .. Array Arguments .. // * .. // * // * Purpose // * ======= // * // * interchanges two vectors. // * uses unrolled loops for increments equal one. // * jack dongarra, linpack, 3/11/78. // * modified 12/3/93, array(1) declarations changed to array(*) // * // * // * .. Local Scalars .. // * .. // * .. Intrinsic Functions .. // INTRINSIC MOD; // * .. #endregion #region Body if (N <= 0) { return; } if (INCX == 1 && INCY == 1) { goto LABEL20; } // * // * code for unequal increments or equal increments not equal // * to 1 // * IX = 1; IY = 1; if (INCX < 0) { IX = (-N + 1) * INCX + 1; } if (INCY < 0) { IY = (-N + 1) * INCY + 1; } for (I = 1; I <= N; I++) { DTEMP = DX[IX + o_dx]; DX[IX + o_dx] = DY[IY + o_dy]; DY[IY + o_dy] = DTEMP; IX += INCX; IY += INCY; } return; // * // * code for both increments equal to 1 // * // * // * clean-up loop // * LABEL20 : M = FortranLib.Mod(N, 3); if (M == 0) { goto LABEL40; } for (I = 1; I <= M; I++) { DTEMP = DX[I + o_dx]; DX[I + o_dx] = DY[I + o_dy]; DY[I + o_dy] = DTEMP; } if (N < 3) { return; } LABEL40 : MP1 = M + 1; for (I = MP1; I <= N; I += 3) { DTEMP = DX[I + o_dx]; DX[I + o_dx] = DY[I + o_dy]; DY[I + o_dy] = DTEMP; DTEMP = DX[I + 1 + o_dx]; DX[I + 1 + o_dx] = DY[I + 1 + o_dy]; DY[I + 1 + o_dy] = DTEMP; DTEMP = DX[I + 2 + o_dx]; DX[I + 2 + o_dx] = DY[I + 2 + o_dy]; DY[I + 2 + o_dy] = DTEMP; } return; #endregion }
/// <summary> /// Purpose /// ======= /// /// DSTEDC computes all eigenvalues and, optionally, eigenvectors of a /// symmetric tridiagonal matrix using the divide and conquer method. /// The eigenvectors of a full or band real symmetric matrix can also be /// found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this /// matrix to tridiagonal form. /// /// This code makes very mild assumptions about floating point /// arithmetic. It will work on machines with a guard digit in /// add/subtract, or on those binary machines without guard digits /// which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. /// It could conceivably fail on hexadecimal or decimal machines /// without guard digits, but we know of none. See DLAED3 for details. /// ///</summary> /// <param name="COMPZ"> /// (input) CHARACTER*1 /// = 'N': Compute eigenvalues only. /// = 'I': Compute eigenvectors of tridiagonal matrix also. /// = 'V': Compute eigenvectors of original dense symmetric /// matrix also. On entry, Z contains the orthogonal /// matrix used to reduce the original matrix to /// tridiagonal form. ///</param> /// <param name="N"> /// (input) INTEGER /// The dimension of the symmetric tridiagonal matrix. N .GE. 0. ///</param> /// <param name="D"> /// (input/output) DOUBLE PRECISION array, dimension (N) /// On entry, the diagonal elements of the tridiagonal matrix. /// On exit, if INFO = 0, the eigenvalues in ascending order. ///</param> /// <param name="E"> /// (input/output) DOUBLE PRECISION array, dimension (N-1) /// On entry, the subdiagonal elements of the tridiagonal matrix. /// On exit, E has been destroyed. ///</param> /// <param name="Z"> /// (input/output) DOUBLE PRECISION array, dimension (LDZ,N) /// On entry, if COMPZ = 'V', then Z contains the orthogonal /// matrix used in the reduction to tridiagonal form. /// On exit, if INFO = 0, then if COMPZ = 'V', Z contains the /// orthonormal eigenvectors of the original symmetric matrix, /// and if COMPZ = 'I', Z contains the orthonormal eigenvectors /// of the symmetric tridiagonal matrix. /// If COMPZ = 'N', then Z is not referenced. ///</param> /// <param name="LDZ"> /// (input) INTEGER /// The leading dimension of the array Z. LDZ .GE. 1. /// If eigenvectors are desired, then LDZ .GE. max(1,N). ///</param> /// <param name="WORK"> /// (workspace/output) DOUBLE PRECISION array, /// dimension (LWORK) /// On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ///</param> /// <param name="LWORK"> /// (input) INTEGER /// The dimension of the array WORK. /// If COMPZ = 'N' or N .LE. 1 then LWORK must be at least 1. /// If COMPZ = 'V' and N .GT. 1 then LWORK must be at least /// ( 1 + 3*N + 2*N*lg N + 3*N**2 ), /// where lg( N ) = smallest integer k such /// that 2**k .GE. N. /// If COMPZ = 'I' and N .GT. 1 then LWORK must be at least /// ( 1 + 4*N + N**2 ). /// Note that for COMPZ = 'I' or 'V', then if N is less than or /// equal to the minimum divide size, usually 25, then LWORK need /// only be max(1,2*(N-1)). /// /// If LWORK = -1, then a workspace query is assumed; the routine /// only calculates the optimal size of the WORK array, returns /// this value as the first entry of the WORK array, and no error /// message related to LWORK is issued by XERBLA. ///</param> /// <param name="IWORK"> /// (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) /// On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. ///</param> /// <param name="LIWORK"> /// (input) INTEGER /// The dimension of the array IWORK. /// If COMPZ = 'N' or N .LE. 1 then LIWORK must be at least 1. /// If COMPZ = 'V' and N .GT. 1 then LIWORK must be at least /// ( 6 + 6*N + 5*N*lg N ). /// If COMPZ = 'I' and N .GT. 1 then LIWORK must be at least /// ( 3 + 5*N ). /// Note that for COMPZ = 'I' or 'V', then if N is less than or /// equal to the minimum divide size, usually 25, then LIWORK /// need only be 1. /// /// If LIWORK = -1, then a workspace query is assumed; the /// routine only calculates the optimal size of the IWORK array, /// returns this value as the first entry of the IWORK array, and /// no error message related to LIWORK is issued by XERBLA. ///</param> /// <param name="INFO"> /// (output) INTEGER /// = 0: successful exit. /// .LT. 0: if INFO = -i, the i-th argument had an illegal value. /// .GT. 0: The algorithm failed to compute an eigenvalue while /// working on the submatrix lying in rows and columns /// INFO/(N+1) through mod(INFO,N+1). ///</param> public void Run(string COMPZ, int N, ref double[] D, int offset_d, ref double[] E, int offset_e, ref double[] Z, int offset_z, int LDZ , ref double[] WORK, int offset_work, int LWORK, ref int[] IWORK, int offset_iwork, int LIWORK, ref int INFO) { #region Variables bool LQUERY = false; int FINISH = 0; int I = 0; int ICOMPZ = 0; int II = 0; int J = 0; int K = 0; int LGN = 0; int LIWMIN = 0; int LWMIN = 0; int M = 0; int SMLSIZ = 0; int START = 0; int STOREZ = 0; int STRTRW = 0; double EPS = 0; double ORGNRM = 0; double P = 0; double TINY = 0; #endregion #region Array Index Correction int o_d = -1 + offset_d; int o_e = -1 + offset_e; int o_z = -1 - LDZ + offset_z; int o_work = -1 + offset_work; int o_iwork = -1 + offset_iwork; #endregion #region Strings COMPZ = COMPZ.Substring(0, 1); #endregion #region Prolog // * // * -- LAPACK driver routine (version 3.1) -- // * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. // * November 2006 // * // * .. Scalar Arguments .. // * .. // * .. Array Arguments .. // * .. // * // * Purpose // * ======= // * // * DSTEDC computes all eigenvalues and, optionally, eigenvectors of a // * symmetric tridiagonal matrix using the divide and conquer method. // * The eigenvectors of a full or band real symmetric matrix can also be // * found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this // * matrix to tridiagonal form. // * // * This code makes very mild assumptions about floating point // * arithmetic. It will work on machines with a guard digit in // * add/subtract, or on those binary machines without guard digits // * which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. // * It could conceivably fail on hexadecimal or decimal machines // * without guard digits, but we know of none. See DLAED3 for details. // * // * Arguments // * ========= // * // * COMPZ (input) CHARACTER*1 // * = 'N': Compute eigenvalues only. // * = 'I': Compute eigenvectors of tridiagonal matrix also. // * = 'V': Compute eigenvectors of original dense symmetric // * matrix also. On entry, Z contains the orthogonal // * matrix used to reduce the original matrix to // * tridiagonal form. // * // * N (input) INTEGER // * The dimension of the symmetric tridiagonal matrix. N >= 0. // * // * D (input/output) DOUBLE PRECISION array, dimension (N) // * On entry, the diagonal elements of the tridiagonal matrix. // * On exit, if INFO = 0, the eigenvalues in ascending order. // * // * E (input/output) DOUBLE PRECISION array, dimension (N-1) // * On entry, the subdiagonal elements of the tridiagonal matrix. // * On exit, E has been destroyed. // * // * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) // * On entry, if COMPZ = 'V', then Z contains the orthogonal // * matrix used in the reduction to tridiagonal form. // * On exit, if INFO = 0, then if COMPZ = 'V', Z contains the // * orthonormal eigenvectors of the original symmetric matrix, // * and if COMPZ = 'I', Z contains the orthonormal eigenvectors // * of the symmetric tridiagonal matrix. // * If COMPZ = 'N', then Z is not referenced. // * // * LDZ (input) INTEGER // * The leading dimension of the array Z. LDZ >= 1. // * If eigenvectors are desired, then LDZ >= max(1,N). // * // * WORK (workspace/output) DOUBLE PRECISION array, // * dimension (LWORK) // * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. // * // * LWORK (input) INTEGER // * The dimension of the array WORK. // * If COMPZ = 'N' or N <= 1 then LWORK must be at least 1. // * If COMPZ = 'V' and N > 1 then LWORK must be at least // * ( 1 + 3*N + 2*N*lg N + 3*N**2 ), // * where lg( N ) = smallest integer k such // * that 2**k >= N. // * If COMPZ = 'I' and N > 1 then LWORK must be at least // * ( 1 + 4*N + N**2 ). // * Note that for COMPZ = 'I' or 'V', then if N is less than or // * equal to the minimum divide size, usually 25, then LWORK need // * only be max(1,2*(N-1)). // * // * If LWORK = -1, then a workspace query is assumed; the routine // * only calculates the optimal size of the WORK array, returns // * this value as the first entry of the WORK array, and no error // * message related to LWORK is issued by XERBLA. // * // * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) // * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. // * // * LIWORK (input) INTEGER // * The dimension of the array IWORK. // * If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1. // * If COMPZ = 'V' and N > 1 then LIWORK must be at least // * ( 6 + 6*N + 5*N*lg N ). // * If COMPZ = 'I' and N > 1 then LIWORK must be at least // * ( 3 + 5*N ). // * Note that for COMPZ = 'I' or 'V', then if N is less than or // * equal to the minimum divide size, usually 25, then LIWORK // * need only be 1. // * // * If LIWORK = -1, then a workspace query is assumed; the // * routine only calculates the optimal size of the IWORK array, // * returns this value as the first entry of the IWORK array, and // * no error message related to LIWORK is issued by XERBLA. // * // * INFO (output) INTEGER // * = 0: successful exit. // * < 0: if INFO = -i, the i-th argument had an illegal value. // * > 0: The algorithm failed to compute an eigenvalue while // * working on the submatrix lying in rows and columns // * INFO/(N+1) through mod(INFO,N+1). // * // * Further Details // * =============== // * // * Based on contributions by // * Jeff Rutter, Computer Science Division, University of California // * at Berkeley, USA // * Modified by Francoise Tisseur, University of Tennessee. // * // * ===================================================================== // * // * .. Parameters .. // * .. // * .. Local Scalars .. // * .. // * .. External Functions .. // * .. // * .. External Subroutines .. // * .. // * .. Intrinsic Functions .. // INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT; // * .. // * .. Executable Statements .. // * // * Test the input parameters. // * #endregion #region Body INFO = 0; LQUERY = (LWORK == -1 || LIWORK == -1); // * if (this._lsame.Run(COMPZ, "N")) { ICOMPZ = 0; } else { if (this._lsame.Run(COMPZ, "V")) { ICOMPZ = 1; } else { if (this._lsame.Run(COMPZ, "I")) { ICOMPZ = 2; } else { ICOMPZ = -1; } } } if (ICOMPZ < 0) { INFO = -1; } else { if (N < 0) { INFO = -2; } else { if ((LDZ < 1) || (ICOMPZ > 0 && LDZ < Math.Max(1, N))) { INFO = -6; } } } // * if (INFO == 0) { // * // * Compute the workspace requirements // * SMLSIZ = this._ilaenv.Run(9, "DSTEDC", " ", 0, 0, 0, 0); if (N <= 1 || ICOMPZ == 0) { LIWMIN = 1; LWMIN = 1; } else { if (N <= SMLSIZ) { LIWMIN = 1; LWMIN = 2 * (N - 1); } else { LGN = Convert.ToInt32(Math.Truncate(Math.Log(Convert.ToDouble(N)) / Math.Log(TWO))); if (Math.Pow(2, LGN) < N) { LGN += 1; } if (Math.Pow(2, LGN) < N) { LGN += 1; } if (ICOMPZ == 1) { LWMIN = 1 + 3 * N + 2 * N * LGN + 3 * (int)Math.Pow(N, 2); LIWMIN = 6 + 6 * N + 5 * N * LGN; } else { if (ICOMPZ == 2) { LWMIN = 1 + 4 * N + (int)Math.Pow(N, 2); LIWMIN = 3 + 5 * N; } } } } WORK[1 + o_work] = LWMIN; IWORK[1 + o_iwork] = LIWMIN; // * if (LWORK < LWMIN && !LQUERY) { INFO = -8; } else { if (LIWORK < LIWMIN && !LQUERY) { INFO = -10; } } } // * if (INFO != 0) { this._xerbla.Run("DSTEDC", -INFO); return; } else { if (LQUERY) { return; } } // * // * Quick return if possible // * if (N == 0) { return; } if (N == 1) { if (ICOMPZ != 0) { Z[1 + 1 * LDZ + o_z] = ONE; } return; } // * // * If the following conditional clause is removed, then the routine // * will use the Divide and Conquer routine to compute only the // * eigenvalues, which requires (3N + 3N**2) real workspace and // * (2 + 5N + 2N lg(N)) integer workspace. // * Since on many architectures DSTERF is much faster than any other // * algorithm for finding eigenvalues only, it is used here // * as the default. If the conditional clause is removed, then // * information on the size of workspace needs to be changed. // * // * If COMPZ = 'N', use DSTERF to compute the eigenvalues. // * if (ICOMPZ == 0) { this._dsterf.Run(N, ref D, offset_d, ref E, offset_e, ref INFO); goto LABEL50; } // * // * If N is smaller than the minimum divide size (SMLSIZ+1), then // * solve the problem with another solver. // * if (N <= SMLSIZ) { // * this._dsteqr.Run(COMPZ, N, ref D, offset_d, ref E, offset_e, ref Z, offset_z, LDZ , ref WORK, offset_work, ref INFO); // * } else { // * // * If COMPZ = 'V', the Z matrix must be stored elsewhere for later // * use. // * if (ICOMPZ == 1) { STOREZ = 1 + N * N; } else { STOREZ = 1; } // * if (ICOMPZ == 2) { this._dlaset.Run("Full", N, N, ZERO, ONE, ref Z, offset_z , LDZ); } // * // * Scale. // * ORGNRM = this._dlanst.Run("M", N, D, offset_d, E, offset_e); if (ORGNRM == ZERO) { goto LABEL50; } // * EPS = this._dlamch.Run("Epsilon"); // * START = 1; // * // * while ( START <= N ) // * LABEL10 :; if (START <= N) { // * // * Let FINISH be the position of the next subdiagonal entry // * such that E( FINISH ) <= TINY or FINISH = N if no such // * subdiagonal exists. The matrix identified by the elements // * between START and FINISH constitutes an independent // * sub-problem. // * FINISH = START; LABEL20 :; if (FINISH < N) { TINY = EPS * Math.Sqrt(Math.Abs(D[FINISH + o_d])) * Math.Sqrt(Math.Abs(D[FINISH + 1 + o_d])); if (Math.Abs(E[FINISH + o_e]) > TINY) { FINISH += 1; goto LABEL20; } } // * // * (Sub) Problem determined. Compute its size and solve it. // * M = FINISH - START + 1; if (M == 1) { START = FINISH + 1; goto LABEL10; } if (M > SMLSIZ) { // * // * Scale. // * ORGNRM = this._dlanst.Run("M", M, D, START + o_d, E, START + o_e); this._dlascl.Run("G", 0, 0, ORGNRM, ONE, M , 1, ref D, START + o_d, M, ref INFO); this._dlascl.Run("G", 0, 0, ORGNRM, ONE, M - 1 , 1, ref E, START + o_e, M - 1, ref INFO); // * if (ICOMPZ == 1) { STRTRW = 1; } else { STRTRW = START; } this._dlaed0.Run(ICOMPZ, N, M, ref D, START + o_d, ref E, START + o_e, ref Z, STRTRW + START * LDZ + o_z , LDZ, ref WORK, 1 + o_work, N, ref WORK, STOREZ + o_work, ref IWORK, offset_iwork, ref INFO); if (INFO != 0) { INFO = (INFO / (M + 1) + START - 1) * (N + 1) + FortranLib.Mod(INFO, (M + 1)) + START - 1; goto LABEL50; } // * // * Scale back. // * this._dlascl.Run("G", 0, 0, ONE, ORGNRM, M , 1, ref D, START + o_d, M, ref INFO); // * } else { if (ICOMPZ == 1) { // * // * Since QR won't update a Z matrix which is larger than // * the length of D, we must solve the sub-problem in a // * workspace and then multiply back into Z. // * this._dsteqr.Run("I", M, ref D, START + o_d, ref E, START + o_e, ref WORK, offset_work, M , ref WORK, M * M + 1 + o_work, ref INFO); this._dlacpy.Run("A", N, M, Z, 1 + START * LDZ + o_z, LDZ, ref WORK, STOREZ + o_work , N); this._dgemm.Run("N", "N", N, M, M, ONE , WORK, STOREZ + o_work, N, WORK, offset_work, M, ZERO, ref Z, 1 + START * LDZ + o_z , LDZ); } else { if (ICOMPZ == 2) { this._dsteqr.Run("I", M, ref D, START + o_d, ref E, START + o_e, ref Z, START + START * LDZ + o_z, LDZ , ref WORK, offset_work, ref INFO); } else { this._dsterf.Run(M, ref D, START + o_d, ref E, START + o_e, ref INFO); } } if (INFO != 0) { INFO = START * (N + 1) + FINISH; goto LABEL50; } } // * START = FINISH + 1; goto LABEL10; } // * // * endwhile // * // * If the problem split any number of times, then the eigenvalues // * will not be properly ordered. Here we permute the eigenvalues // * (and the associated eigenvectors) into ascending order. // * if (M != N) { if (ICOMPZ == 0) { // * // * Use Quick Sort // * this._dlasrt.Run("I", N, ref D, offset_d, ref INFO); // * } else { // * // * Use Selection Sort to minimize swaps of eigenvectors // * for (II = 2; II <= N; II++) { I = II - 1; K = I; P = D[I + o_d]; for (J = II; J <= N; J++) { if (D[J + o_d] < P) { K = J; P = D[J + o_d]; } } if (K != I) { D[K + o_d] = D[I + o_d]; D[I + o_d] = P; this._dswap.Run(N, ref Z, 1 + I * LDZ + o_z, 1, ref Z, 1 + K * LDZ + o_z, 1); } } } } } // * LABEL50 :; WORK[1 + o_work] = LWMIN; IWORK[1 + o_iwork] = LIWMIN; // * return; // * // * End of DSTEDC // * #endregion }
/// <summary> /// Purpose /// ======= /// /// DSTERF computes all eigenvalues of a symmetric tridiagonal matrix /// using the Pal-Walker-Kahan variant of the QL or QR algorithm. /// ///</summary> /// <param name="N"> /// (input) INTEGER /// The order of the matrix. N .GE. 0. ///</param> /// <param name="D"> /// (input/output) DOUBLE PRECISION array, dimension (N) /// On entry, the n diagonal elements of the tridiagonal matrix. /// On exit, if INFO = 0, the eigenvalues in ascending order. ///</param> /// <param name="E"> /// (input/output) DOUBLE PRECISION array, dimension (N-1) /// On entry, the (n-1) subdiagonal elements of the tridiagonal /// matrix. /// On exit, E has been destroyed. ///</param> /// <param name="INFO"> /// (output) INTEGER /// = 0: successful exit /// .LT. 0: if INFO = -i, the i-th argument had an illegal value /// .GT. 0: the algorithm failed to find all of the eigenvalues in /// a total of 30*N iterations; if INFO = i, then i /// elements of E have not converged to zero. ///</param> public void Run(int N, ref double[] D, int offset_d, ref double[] E, int offset_e, ref int INFO) { #region Variables int I = 0; int ISCALE = 0; int JTOT = 0; int L = 0; int L1 = 0; int LEND = 0; int LENDSV = 0; int LSV = 0; int M = 0; int NMAXIT = 0; double ALPHA = 0; double ANORM = 0; double BB = 0; double C = 0; double EPS = 0; double EPS2 = 0; double GAMMA = 0; double OLDC = 0; double OLDGAM = 0; double P = 0; double R = 0; double RT1 = 0; double RT2 = 0; double RTE = 0; double S = 0; double SAFMAX = 0; double SAFMIN = 0; double SIGMA = 0; double SSFMAX = 0; double SSFMIN = 0; #endregion #region Array Index Correction int o_d = -1 + offset_d; int o_e = -1 + offset_e; #endregion #region Prolog // * // * -- LAPACK routine (version 3.1) -- // * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. // * November 2006 // * // * .. Scalar Arguments .. // * .. // * .. Array Arguments .. // * .. // * // * Purpose // * ======= // * // * DSTERF computes all eigenvalues of a symmetric tridiagonal matrix // * using the Pal-Walker-Kahan variant of the QL or QR algorithm. // * // * Arguments // * ========= // * // * N (input) INTEGER // * The order of the matrix. N >= 0. // * // * D (input/output) DOUBLE PRECISION array, dimension (N) // * On entry, the n diagonal elements of the tridiagonal matrix. // * On exit, if INFO = 0, the eigenvalues in ascending order. // * // * E (input/output) DOUBLE PRECISION array, dimension (N-1) // * On entry, the (n-1) subdiagonal elements of the tridiagonal // * matrix. // * On exit, E has been destroyed. // * // * INFO (output) INTEGER // * = 0: successful exit // * < 0: if INFO = -i, the i-th argument had an illegal value // * > 0: the algorithm failed to find all of the eigenvalues in // * a total of 30*N iterations; if INFO = i, then i // * elements of E have not converged to zero. // * // * ===================================================================== // * // * .. Parameters .. // * .. // * .. Local Scalars .. // * .. // * .. External Functions .. // * .. // * .. External Subroutines .. // * .. // * .. Intrinsic Functions .. // INTRINSIC ABS, SIGN, SQRT; // * .. // * .. Executable Statements .. // * // * Test the input parameters. // * #endregion #region Body INFO = 0; // * // * Quick return if possible // * if (N < 0) { INFO = -1; this._xerbla.Run("DSTERF", -INFO); return; } if (N <= 1) { return; } // * // * Determine the unit roundoff for this environment. // * EPS = this._dlamch.Run("E"); EPS2 = Math.Pow(EPS, 2); SAFMIN = this._dlamch.Run("S"); SAFMAX = ONE / SAFMIN; SSFMAX = Math.Sqrt(SAFMAX) / THREE; SSFMIN = Math.Sqrt(SAFMIN) / EPS2; // * // * Compute the eigenvalues of the tridiagonal matrix. // * NMAXIT = N * MAXIT; SIGMA = ZERO; JTOT = 0; // * // * Determine where the matrix splits and choose QL or QR iteration // * for each block, according to whether top or bottom diagonal // * element is smaller. // * L1 = 1; // * LABEL10 :; if (L1 > N) { goto LABEL170; } if (L1 > 1) { E[L1 - 1 + o_e] = ZERO; } for (M = L1; M <= N - 1; M++) { if (Math.Abs(E[M + o_e]) <= (Math.Sqrt(Math.Abs(D[M + o_d])) * Math.Sqrt(Math.Abs(D[M + 1 + o_d]))) * EPS) { E[M + o_e] = ZERO; goto LABEL30; } } M = N; // * LABEL30 :; L = L1; LSV = L; LEND = M; LENDSV = LEND; L1 = M + 1; if (LEND == L) { goto LABEL10; } // * // * Scale submatrix in rows and columns L to LEND // * ANORM = this._dlanst.Run("I", LEND - L + 1, D, L + o_d, E, L + o_e); ISCALE = 0; if (ANORM > SSFMAX) { ISCALE = 1; this._dlascl.Run("G", 0, 0, ANORM, SSFMAX, LEND - L + 1 , 1, ref D, L + o_d, N, ref INFO); this._dlascl.Run("G", 0, 0, ANORM, SSFMAX, LEND - L , 1, ref E, L + o_e, N, ref INFO); } else { if (ANORM < SSFMIN) { ISCALE = 2; this._dlascl.Run("G", 0, 0, ANORM, SSFMIN, LEND - L + 1 , 1, ref D, L + o_d, N, ref INFO); this._dlascl.Run("G", 0, 0, ANORM, SSFMIN, LEND - L , 1, ref E, L + o_e, N, ref INFO); } } // * for (I = L; I <= LEND - 1; I++) { E[I + o_e] = Math.Pow(E[I + o_e], 2); } // * // * Choose between QL and QR iteration // * if (Math.Abs(D[LEND + o_d]) < Math.Abs(D[L + o_d])) { LEND = LSV; L = LENDSV; } // * if (LEND >= L) { // * // * QL Iteration // * // * Look for small subdiagonal element. // * LABEL50 :; if (L != LEND) { for (M = L; M <= LEND - 1; M++) { if (Math.Abs(E[M + o_e]) <= EPS2 * Math.Abs(D[M + o_d] * D[M + 1 + o_d])) { goto LABEL70; } } } M = LEND; // * LABEL70 :; if (M < LEND) { E[M + o_e] = ZERO; } P = D[L + o_d]; if (M == L) { goto LABEL90; } // * // * If remaining matrix is 2 by 2, use DLAE2 to compute its // * eigenvalues. // * if (M == L + 1) { RTE = Math.Sqrt(E[L + o_e]); this._dlae2.Run(D[L + o_d], RTE, D[L + 1 + o_d], ref RT1, ref RT2); D[L + o_d] = RT1; D[L + 1 + o_d] = RT2; E[L + o_e] = ZERO; L += 2; if (L <= LEND) { goto LABEL50; } goto LABEL150; } // * if (JTOT == NMAXIT) { goto LABEL150; } JTOT += 1; // * // * Form shift. // * RTE = Math.Sqrt(E[L + o_e]); SIGMA = (D[L + 1 + o_d] - P) / (TWO * RTE); R = this._dlapy2.Run(SIGMA, ONE); SIGMA = P - (RTE / (SIGMA + FortranLib.Sign(R, SIGMA))); // * C = ONE; S = ZERO; GAMMA = D[M + o_d] - SIGMA; P = GAMMA * GAMMA; // * // * Inner loop // * for (I = M - 1; I >= L; I += -1) { BB = E[I + o_e]; R = P + BB; if (I != M - 1) { E[I + 1 + o_e] = S * R; } OLDC = C; C = P / R; S = BB / R; OLDGAM = GAMMA; ALPHA = D[I + o_d]; GAMMA = C * (ALPHA - SIGMA) - S * OLDGAM; D[I + 1 + o_d] = OLDGAM + (ALPHA - GAMMA); if (C != ZERO) { P = (GAMMA * GAMMA) / C; } else { P = OLDC * BB; } } // * E[L + o_e] = S * P; D[L + o_d] = SIGMA + GAMMA; goto LABEL50; // * // * Eigenvalue found. // * LABEL90 :; D[L + o_d] = P; // * L += 1; if (L <= LEND) { goto LABEL50; } goto LABEL150; // * } else { // * // * QR Iteration // * // * Look for small superdiagonal element. // * LABEL100 :; for (M = L; M >= LEND + 1; M += -1) { if (Math.Abs(E[M - 1 + o_e]) <= EPS2 * Math.Abs(D[M + o_d] * D[M - 1 + o_d])) { goto LABEL120; } } M = LEND; // * LABEL120 :; if (M > LEND) { E[M - 1 + o_e] = ZERO; } P = D[L + o_d]; if (M == L) { goto LABEL140; } // * // * If remaining matrix is 2 by 2, use DLAE2 to compute its // * eigenvalues. // * if (M == L - 1) { RTE = Math.Sqrt(E[L - 1 + o_e]); this._dlae2.Run(D[L + o_d], RTE, D[L - 1 + o_d], ref RT1, ref RT2); D[L + o_d] = RT1; D[L - 1 + o_d] = RT2; E[L - 1 + o_e] = ZERO; L -= 2; if (L >= LEND) { goto LABEL100; } goto LABEL150; } // * if (JTOT == NMAXIT) { goto LABEL150; } JTOT += 1; // * // * Form shift. // * RTE = Math.Sqrt(E[L - 1 + o_e]); SIGMA = (D[L - 1 + o_d] - P) / (TWO * RTE); R = this._dlapy2.Run(SIGMA, ONE); SIGMA = P - (RTE / (SIGMA + FortranLib.Sign(R, SIGMA))); // * C = ONE; S = ZERO; GAMMA = D[M + o_d] - SIGMA; P = GAMMA * GAMMA; // * // * Inner loop // * for (I = M; I <= L - 1; I++) { BB = E[I + o_e]; R = P + BB; if (I != M) { E[I - 1 + o_e] = S * R; } OLDC = C; C = P / R; S = BB / R; OLDGAM = GAMMA; ALPHA = D[I + 1 + o_d]; GAMMA = C * (ALPHA - SIGMA) - S * OLDGAM; D[I + o_d] = OLDGAM + (ALPHA - GAMMA); if (C != ZERO) { P = (GAMMA * GAMMA) / C; } else { P = OLDC * BB; } } // * E[L - 1 + o_e] = S * P; D[L + o_d] = SIGMA + GAMMA; goto LABEL100; // * // * Eigenvalue found. // * LABEL140 :; D[L + o_d] = P; // * L -= 1; if (L >= LEND) { goto LABEL100; } goto LABEL150; // * } // * // * Undo scaling if necessary // * LABEL150 :; if (ISCALE == 1) { this._dlascl.Run("G", 0, 0, SSFMAX, ANORM, LENDSV - LSV + 1 , 1, ref D, LSV + o_d, N, ref INFO); } if (ISCALE == 2) { this._dlascl.Run("G", 0, 0, SSFMIN, ANORM, LENDSV - LSV + 1 , 1, ref D, LSV + o_d, N, ref INFO); } // * // * Check for no convergence to an eigenvalue after a total // * of N*MAXIT iterations. // * if (JTOT < NMAXIT) { goto LABEL10; } for (I = 1; I <= N - 1; I++) { if (E[I + o_e] != ZERO) { INFO += 1; } } goto LABEL180; // * // * Sort eigenvalues in increasing order. // * LABEL170 :; this._dlasrt.Run("I", N, ref D, offset_d, ref INFO); // * LABEL180 :; return; // * // * End of DSTERF // * #endregion }