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
}
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, 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
}
/// <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 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
/// =======
///
/// takes the sum of the absolute values.
/// 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 double Run(int N, double[] DX, int offset_dx, int INCX)
{
double dasum = 0;
#region Variables
double DTEMP = 0; 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
// * =======
// *
// * takes the sum of the absolute values.
// * 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 DABS,MOD;
// * ..
#endregion
#region Body
dasum = 0.0E0;
DTEMP = 0.0E0;
if (N <= 0 || INCX <= 0)
{
return(dasum);
}
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)
{
DTEMP += Math.Abs(DX[I + o_dx]);
}
dasum = DTEMP;
return(dasum);
// *
// * code for increment equal to 1
// *
// *
// * clean-up loop
// *
LABEL20 : M = FortranLib.Mod(N, 6);
if (M == 0)
{
goto LABEL40;
}
for (I = 1; I <= M; I++)
{
DTEMP += Math.Abs(DX[I + o_dx]);
}
if (N < 6)
{
goto LABEL60;
}
LABEL40 : MP1 = M + 1;
for (I = MP1; I <= N; I += 6)
{
DTEMP += Math.Abs(DX[I + o_dx]) + Math.Abs(DX[I + 1 + o_dx]) + Math.Abs(DX[I + 2 + o_dx]) + Math.Abs(DX[I + 3 + o_dx]) + Math.Abs(DX[I + 4 + o_dx]) + Math.Abs(DX[I + 5 + o_dx]);
}
LABEL60 : dasum = DTEMP;
return(dasum);
#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
/// =======
/// *
/// 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
}
/// <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, 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
}
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
}
/// <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
}
/// <param name="N">
/// is an integer variable.
/// On entry n is the dimension of the problem.
/// On exit n is unchanged.
///</param>
/// <param name="NSUB">
/// is an integer variable
/// On entry nsub is the number of subspace variables in free set.
/// On exit nsub is not changed.
///</param>
/// <param name="IND">
/// is an integer array of dimension nsub.
/// On entry ind specifies the indices of subspace variables.
/// On exit ind is unchanged.
///</param>
/// <param name="NENTER">
/// is an integer variable.
/// On entry nenter is the number of variables entering the
/// free set.
/// On exit nenter is unchanged.
///</param>
/// <param name="ILEAVE">
/// is an integer variable.
/// On entry indx2(ileave),...,indx2(n) are the variables leaving
/// the free set.
/// On exit ileave is unchanged.
///</param>
/// <param name="INDX2">
/// is an integer array of dimension n.
/// On entry indx2(1),...,indx2(nenter) are the variables entering
/// the free set, while indx2(ileave),...,indx2(n) are the
/// variables leaving the free set.
/// On exit indx2 is unchanged.
///</param>
/// <param name="IUPDAT">
/// is an integer variable.
/// On entry iupdat is the total number of BFGS updates made so far.
/// On exit iupdat is unchanged.
///</param>
/// <param name="UPDATD">
/// is a logical variable.
/// On entry 'updatd' is true if the L-BFGS matrix is updatd.
/// On exit 'updatd' is unchanged.
///</param>
/// <param name="WN">
/// is a double precision array of dimension 2m x 2m.
/// On entry wn is unspecified.
/// On exit the upper triangle of wn stores the LEL^T factorization
/// of the 2*col x 2*col indefinite matrix
/// [-D -Y'ZZ'Y/theta L_a'-R_z' ]
/// [L_a -R_z theta*S'AA'S ]
///</param>
/// <param name="WN1">
/// is a double precision array of dimension 2m x 2m.
/// On entry wn1 stores the lower triangular part of
/// [Y' ZZ'Y L_a'+R_z']
/// [L_a+R_z S'AA'S ]
/// in the previous iteration.
/// On exit wn1 stores the corresponding updated matrices.
/// The purpose of wn1 is just to store these inner products
/// so they can be easily updated and inserted into wn.
///</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="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;
/// sy(m,m) stores S'Y;
/// wtyy(m,m) stores the Cholesky factorization
/// of (theta*S'S+LD^(-1)L')
/// 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="INFO">
/// is an integer variable.
/// On entry info is unspecified.
/// On exit info = 0 for normal return;
/// = -1 when the 1st Cholesky factorization failed;
/// = -2 when the 2st Cholesky factorization failed.
///</param>
public void Run(int N, int NSUB, int[] IND, int offset_ind, int NENTER, int ILEAVE, int[] INDX2, int offset_indx2
, int IUPDAT, bool UPDATD, ref double[] WN, int offset_wn, ref double[] WN1, int offset_wn1, int M, double[] WS, int offset_ws
, double[] WY, int offset_wy, double[] SY, int offset_sy, double THETA, int COL, int HEAD, ref int INFO)
{
#region Variables
int M2 = 0; int IPNTR = 0; int JPNTR = 0; int IY = 0; int IS = 0; int JY = 0; int JS = 0; int IS1 = 0; int JS1 = 0;
int K1 = 0; int I = 0; int K = 0; int COL2 = 0; int PBEGIN = 0; int PEND = 0; int DBEGIN = 0; int DEND = 0;
int UPCL = 0; double TEMP1 = 0; double TEMP2 = 0; double TEMP3 = 0; double TEMP4 = 0;
#endregion
#region Implicit Variables
int WN_IY = 0; int WN_IS = 0;
#endregion
#region Array Index Correction
int o_ind = -1 + offset_ind; int o_indx2 = -1 + offset_indx2; int o_wn = -1 - (2 * M) + offset_wn;
int o_wn1 = -1 - (2 * M) + offset_wn1; int o_ws = -1 - N + offset_ws; int o_wy = -1 - N + offset_wy;
int o_sy = -1 - M + offset_sy;
#endregion
#region Prolog
// c ************
// c
// c Subroutine formk
// c
// c This subroutine forms the LEL^T factorization of the indefinite
// c
// c matrix 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 The matrix K can be shown to be equal to the matrix M^[-1]N
// c occurring in section 5.1 of [1], as well as to the matrix
// c Mbar^[-1] Nbar in section 5.3.
// 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 nsub is an integer variable
// c On entry nsub is the number of subspace variables in free set.
// c On exit nsub is not changed.
// c
// c ind is an integer array of dimension nsub.
// c On entry ind specifies the indices of subspace variables.
// c On exit ind is unchanged.
// c
// c nenter is an integer variable.
// c On entry nenter is the number of variables entering the
// c free set.
// c On exit nenter is unchanged.
// c
// c ileave is an integer variable.
// c On entry indx2(ileave),...,indx2(n) are the variables leaving
// c the free set.
// c On exit ileave is unchanged.
// c
// c indx2 is an integer array of dimension n.
// c On entry indx2(1),...,indx2(nenter) are the variables entering
// c the free set, while indx2(ileave),...,indx2(n) are the
// c variables leaving the free set.
// c On exit indx2 is unchanged.
// c
// c iupdat is an integer variable.
// c On entry iupdat is the total number of BFGS updates made so far.
// c On exit iupdat is unchanged.
// c
// c updatd is a logical variable.
// c On entry 'updatd' is true if the L-BFGS matrix is updatd.
// c On exit 'updatd' is unchanged.
// c
// c wn is a double precision array of dimension 2m x 2m.
// c On entry wn is unspecified.
// c On exit the upper triangle of wn stores the LEL^T factorization
// c of the 2*col x 2*col indefinite matrix
// c [-D -Y'ZZ'Y/theta L_a'-R_z' ]
// c [L_a -R_z theta*S'AA'S ]
// c
// c wn1 is a double precision array of dimension 2m x 2m.
// c On entry wn1 stores the lower triangular part of
// c [Y' ZZ'Y L_a'+R_z']
// c [L_a+R_z S'AA'S ]
// c in the previous iteration.
// c On exit wn1 stores the corresponding updated matrices.
// c The purpose of wn1 is just to store these inner products
// c so they can be easily updated and inserted into wn.
// 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 ws, wy, sy, and wtyy 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 sy(m,m) stores S'Y;
// c wtyy(m,m) stores the Cholesky factorization
// c of (theta*S'S+LD^(-1)L')
// 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 info is an integer variable.
// c On entry info is unspecified.
// c On exit info = 0 for normal return;
// c = -1 when the 1st Cholesky factorization failed;
// c = -2 when the 2st Cholesky factorization failed.
// c
// c Subprograms called:
// c
// c Linpack ... dcopy, dpofa, dtrsl.
// c
// c
// c References:
// 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 [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: a
// c limited memory FORTRAN code for solving bound constrained
// c optimization problems'', Tech. Report, NAM-11, EECS Department,
// c Northwestern University, 1994.
// c
// c (Postscript files of these papers are available via anonymous
// c ftp to eecs.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.)
// 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 Form the lower triangular part of
// c WN1 = [Y' ZZ'Y L_a'+R_z']
// c [L_a+R_z S'AA'S ]
// c where L_a is the strictly lower triangular part of S'AA'Y
// c R_z is the upper triangular part of S'ZZ'Y.
#endregion
#region Body
if (UPDATD)
{
if (IUPDAT > M)
{
// c shift old part of WN1.
for (JY = 1; JY <= M - 1; JY++)
{
JS = M + JY;
this._dcopy.Run(M - JY, WN1, JY + 1 + (JY + 1) * (2 * M) + o_wn1, 1, ref WN1, JY + JY * (2 * M) + o_wn1, 1);
this._dcopy.Run(M - JY, WN1, JS + 1 + (JS + 1) * (2 * M) + o_wn1, 1, ref WN1, JS + JS * (2 * M) + o_wn1, 1);
this._dcopy.Run(M - 1, WN1, M + 2 + (JY + 1) * (2 * M) + o_wn1, 1, ref WN1, M + 1 + JY * (2 * M) + o_wn1, 1);
}
}
// c put new rows in blocks (1,1), (2,1) and (2,2).
PBEGIN = 1;
PEND = NSUB;
DBEGIN = NSUB + 1;
DEND = N;
IY = COL;
IS = M + COL;
IPNTR = HEAD + COL - 1;
if (IPNTR > M)
{
IPNTR -= M;
}
JPNTR = HEAD;
for (JY = 1; JY <= COL; JY++)
{
JS = M + JY;
TEMP1 = ZERO;
TEMP2 = ZERO;
TEMP3 = ZERO;
// c compute element jy of row 'col' of Y'ZZ'Y
for (K = PBEGIN; K <= PEND; K++)
{
K1 = IND[K + o_ind];
TEMP1 += WY[K1 + IPNTR * N + o_wy] * WY[K1 + JPNTR * N + o_wy];
}
// c compute elements jy of row 'col' of L_a and S'AA'S
for (K = DBEGIN; K <= DEND; K++)
{
K1 = IND[K + o_ind];
TEMP2 += WS[K1 + IPNTR * N + o_ws] * WS[K1 + JPNTR * N + o_ws];
TEMP3 += WS[K1 + IPNTR * N + o_ws] * WY[K1 + JPNTR * N + o_wy];
}
WN1[IY + JY * (2 * M) + o_wn1] = TEMP1;
WN1[IS + JS * (2 * M) + o_wn1] = TEMP2;
WN1[IS + JY * (2 * M) + o_wn1] = TEMP3;
JPNTR = FortranLib.Mod(JPNTR, M) + 1;
}
// c put new column in block (2,1).
JY = COL;
JPNTR = HEAD + COL - 1;
if (JPNTR > M)
{
JPNTR -= M;
}
IPNTR = HEAD;
for (I = 1; I <= COL; I++)
{
IS = M + I;
TEMP3 = ZERO;
// c compute element i of column 'col' of R_z
for (K = PBEGIN; K <= PEND; K++)
{
K1 = IND[K + o_ind];
TEMP3 += WS[K1 + IPNTR * N + o_ws] * WY[K1 + JPNTR * N + o_wy];
}
IPNTR = FortranLib.Mod(IPNTR, M) + 1;
WN1[IS + JY * (2 * M) + o_wn1] = TEMP3;
}
UPCL = COL - 1;
}
else
{
UPCL = COL;
}
// c modify the old parts in blocks (1,1) and (2,2) due to changes
// c in the set of free variables.
IPNTR = HEAD;
for (IY = 1; IY <= UPCL; IY++)
{
IS = M + IY;
JPNTR = HEAD;
for (JY = 1; JY <= IY; JY++)
{
JS = M + JY;
TEMP1 = ZERO;
TEMP2 = ZERO;
TEMP3 = ZERO;
TEMP4 = ZERO;
for (K = 1; K <= NENTER; K++)
{
K1 = INDX2[K + o_indx2];
TEMP1 += WY[K1 + IPNTR * N + o_wy] * WY[K1 + JPNTR * N + o_wy];
TEMP2 += WS[K1 + IPNTR * N + o_ws] * WS[K1 + JPNTR * N + o_ws];
}
for (K = ILEAVE; K <= N; K++)
{
K1 = INDX2[K + o_indx2];
TEMP3 += WY[K1 + IPNTR * N + o_wy] * WY[K1 + JPNTR * N + o_wy];
TEMP4 += WS[K1 + IPNTR * N + o_ws] * WS[K1 + JPNTR * N + o_ws];
}
WN1[IY + JY * (2 * M) + o_wn1] += TEMP1 - TEMP3;
WN1[IS + JS * (2 * M) + o_wn1] += -TEMP2 + TEMP4;
JPNTR = FortranLib.Mod(JPNTR, M) + 1;
}
IPNTR = FortranLib.Mod(IPNTR, M) + 1;
}
// c modify the old parts in block (2,1).
IPNTR = HEAD;
for (IS = M + 1; IS <= M + UPCL; IS++)
{
JPNTR = HEAD;
for (JY = 1; JY <= UPCL; JY++)
{
TEMP1 = ZERO;
TEMP3 = ZERO;
for (K = 1; K <= NENTER; K++)
{
K1 = INDX2[K + o_indx2];
TEMP1 += WS[K1 + IPNTR * N + o_ws] * WY[K1 + JPNTR * N + o_wy];
}
for (K = ILEAVE; K <= N; K++)
{
K1 = INDX2[K + o_indx2];
TEMP3 += WS[K1 + IPNTR * N + o_ws] * WY[K1 + JPNTR * N + o_wy];
}
if (IS <= JY + M)
{
WN1[IS + JY * (2 * M) + o_wn1] += TEMP1 - TEMP3;
}
else
{
WN1[IS + JY * (2 * M) + o_wn1] += -TEMP1 + TEMP3;
}
JPNTR = FortranLib.Mod(JPNTR, M) + 1;
}
IPNTR = FortranLib.Mod(IPNTR, M) + 1;
}
// c Form the upper triangle of WN = [D+Y' ZZ'Y/theta -L_a'+R_z' ]
// c [-L_a +R_z S'AA'S*theta]
M2 = 2 * M;
for (IY = 1; IY <= COL; IY++)
{
IS = COL + IY;
IS1 = M + IY;
WN_IY = IY * (2 * M) + o_wn;
for (JY = 1; JY <= IY; JY++)
{
JS = COL + JY;
JS1 = M + JY;
WN[JY + WN_IY] = WN1[IY + JY * (2 * M) + o_wn1] / THETA;
WN[JS + IS * (2 * M) + o_wn] = WN1[IS1 + JS1 * (2 * M) + o_wn1] * THETA;
}
WN_IS = IS * (2 * M) + o_wn;
for (JY = 1; JY <= IY - 1; JY++)
{
WN[JY + WN_IS] = -WN1[IS1 + JY * (2 * M) + o_wn1];
}
WN_IS = IS * (2 * M) + o_wn;
for (JY = IY; JY <= COL; JY++)
{
WN[JY + WN_IS] = WN1[IS1 + JY * (2 * M) + o_wn1];
}
WN[IY + IY * (2 * M) + o_wn] += SY[IY + IY * M + o_sy];
}
// c Form the upper triangle of WN= [ LL' L^-1(-L_a'+R_z')]
// c [(-L_a +R_z)L'^-1 S'AA'S*theta ]
// c first Cholesky factor (1,1) block of wn to get LL'
// c with L' stored in the upper triangle of wn.
this._dpofa.Run(ref WN, offset_wn, M2, COL, ref INFO);
if (INFO != 0)
{
INFO = -1;
return;
}
// c then form L^-1(-L_a'+R_z') in the (1,2) block.
COL2 = 2 * COL;
for (JS = COL + 1; JS <= COL2; JS++)
{
this._dtrsl.Run(WN, offset_wn, M2, COL, ref WN, 1 + JS * (2 * M) + o_wn, 11, ref INFO);
}
// c Form S'AA'S*theta + (L^-1(-L_a'+R_z'))'L^-1(-L_a'+R_z') in the
// c upper triangle of (2,2) block of wn.
for (IS = COL + 1; IS <= COL2; IS++)
{
for (JS = IS; JS <= COL2; JS++)
{
WN[IS + JS * (2 * M) + o_wn] += this._ddot.Run(COL, WN, 1 + IS * (2 * M) + o_wn, 1, WN, 1 + JS * (2 * M) + o_wn, 1);
}
}
// c Cholesky factorization of (2,2) block of wn.
this._dpofa.Run(ref WN, COL + 1 + (COL + 1) * (2 * M) + o_wn, M2, COL, ref INFO);
if (INFO != 0)
{
INFO = -2;
return;
}
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="X">
/// is a double precision array of dimension n.
/// On entry x is the starting point for the GCP computation.
/// On exit x 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 an 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="G">
/// is a double precision array of dimension n.
/// On entry g is the gradient of f(x). g must be a nonzero vector.
/// On exit g is unchanged.
///</param>
/// <param name="IORDER">
/// is an integer working array of dimension n.
/// iorder will be used to store the breakpoints in the piecewise
/// linear path and free variables encountered. On exit,
/// iorder(1),...,iorder(nleft) are indices of breakpoints
/// which have not been encountered;
/// iorder(nleft+1),...,iorder(nbreak) are indices of
/// encountered breakpoints; and
/// iorder(nfree),...,iorder(n) are indices of variables which
/// have no bound constraits along the search direction.
///</param>
/// <param name="IWHERE">
/// is an integer array of dimension n.
/// On entry iwhere indicates only the permanently fixed (iwhere=3)
/// or free (iwhere= -1) components of x.
/// On exit iwhere records the status of the current x variables.
/// iwhere(i)=-3 if x(i) is free and has bounds, but is not moved
/// 0 if x(i) is free and has bounds, and is moved
/// 1 if x(i) is fixed at l(i), and l(i) .ne. u(i)
/// 2 if x(i) is fixed at u(i), and u(i) .ne. l(i)
/// 3 if x(i) is always fixed, i.e., u(i)=x(i)=l(i)
/// -1 if x(i) is always free, i.e., it has no bounds.
///</param>
/// <param name="T">
/// is a double precision working array of dimension n.
/// t will be used to store the break points.
///</param>
/// <param name="D">
/// is a double precision array of dimension n used to store
/// the Cauchy direction P(x-tg)-x.
///</param>
/// <param name="XCP">
/// is a double precision array of dimension n used to return the
/// GCP on exit.
///</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="THETA">
/// is a double precision variable.
/// On entry theta is the scaling factor specifying B_0 = theta I.
/// On exit theta is unchanged.
///</param>
/// <param name="COL">
/// is an integer variable.
/// On entry col is the actual number of variable metric
/// corrections stored so far.
/// On exit col is unchanged.
///</param>
/// <param name="HEAD">
/// is an integer variable.
/// On entry head is the location of the first s-vector (or y-vector)
/// in S (or Y).
/// On exit col is unchanged.
///</param>
/// <param name="P">
/// is a double precision working array of dimension 2m.
/// p will be used to store the vector p = W^(T)d.
///</param>
/// <param name="C">
/// is a double precision working array of dimension 2m.
/// c will be used to store the vector c = W^(T)(xcp-x).
///</param>
/// <param name="WBP">
/// is a double precision working array of dimension 2m.
/// wbp will be used to store the row of W corresponding
/// to a breakpoint.
///</param>
/// <param name="V">
/// is a double precision working array of dimension 2m.
///</param>
/// <param name="NINT">
/// is an integer variable.
/// On exit nint records the number of quadratic segments explored
/// in searching for the GCP.
///</param>
/// <param name="SG">
/// and yg are double precision arrays of dimension m.
/// On entry sg and yg store S'g and Y'g correspondingly.
/// On exit they are 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="SBGNRM">
/// is a double precision variable.
/// On entry sbgnrm is the norm of the projected gradient at x.
/// On exit sbgnrm is unchanged.
///</param>
/// <param name="INFO">
/// is an integer variable.
/// On entry info is 0.
/// On exit info = 0 for normal return,
/// = nonzero for abnormal return when the the system
/// used in routine bmv is singular.
///</param>
public void Run(int N, double[] X, int offset_x, double[] L, int offset_l, double[] U, int offset_u, int[] NBD, int offset_nbd, double[] G, int offset_g
, ref int[] IORDER, int offset_iorder, ref int[] IWHERE, int offset_iwhere, ref double[] T, int offset_t, ref double[] D, int offset_d, ref double[] XCP, int offset_xcp, int M
, double[] WY, int offset_wy, double[] WS, int offset_ws, double[] SY, int offset_sy, double[] WT, int offset_wt, double THETA, int COL
, int HEAD, ref double[] P, int offset_p, ref double[] C, int offset_c, ref double[] WBP, int offset_wbp, ref double[] V, int offset_v, ref int NINT
, double[] SG, int offset_sg, double[] YG, int offset_yg, int IPRINT, double SBGNRM, ref int INFO, double EPSMCH)
{
#region Variables
bool XLOWER = false; bool XUPPER = false; bool BNDED = false; int I = 0; int J = 0; int COL2 = 0; int NFREE = 0;
int NBREAK = 0; int POINTR = 0; int IBP = 0; int NLEFT = 0; int IBKMIN = 0; int ITER = 0; double F1 = 0; double F2 = 0;
double DT = 0; double DTM = 0; double TSUM = 0; double DIBP = 0; double ZIBP = 0; double DIBP2 = 0; double BKMIN = 0;
double TU = 0; double TL = 0; double WMC = 0; double WMP = 0; double WMW = 0; double TJ = 0; double TJ0 = 0;
double NEGGI = 0; double F2_ORG = 0;
#endregion
#region Array Index Correction
int o_x = -1 + offset_x; int o_l = -1 + offset_l; int o_u = -1 + offset_u; int o_nbd = -1 + offset_nbd;
int o_g = -1 + offset_g; int o_iorder = -1 + offset_iorder; int o_iwhere = -1 + offset_iwhere;
int o_t = -1 + offset_t; int o_d = -1 + offset_d; int o_xcp = -1 + offset_xcp; int o_wy = -1 - N + offset_wy;
int o_ws = -1 - N + offset_ws; int o_sy = -1 - M + offset_sy; int o_wt = -1 - M + offset_wt;
int o_p = -1 + offset_p; int o_c = -1 + offset_c; int o_wbp = -1 + offset_wbp; int o_v = -1 + offset_v;
int o_sg = -1 + offset_sg; int o_yg = -1 + offset_yg;
#endregion
#region Prolog
// c ************
// c
// c Subroutine cauchy
// c
// c For given x, l, u, g (with sbgnrm > 0), and a limited memory
// c BFGS matrix B defined in terms of matrices WY, WS, WT, and
// c scalars head, col, and theta, this subroutine computes the
// c generalized Cauchy point (GCP), defined as the first local
// c minimizer of the quadratic
// c
// c Q(x + s) = g's + 1/2 s'Bs
// c
// c along the projected gradient direction P(x-tg,l,u).
// c The routine returns the GCP in xcp.
// 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 x is a double precision array of dimension n.
// c On entry x is the starting point for the GCP computation.
// c On exit x 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 an 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 g is a double precision array of dimension n.
// c On entry g is the gradient of f(x). g must be a nonzero vector.
// c On exit g is unchanged.
// c
// c iorder is an integer working array of dimension n.
// c iorder will be used to store the breakpoints in the piecewise
// c linear path and free variables encountered. On exit,
// c iorder(1),...,iorder(nleft) are indices of breakpoints
// c which have not been encountered;
// c iorder(nleft+1),...,iorder(nbreak) are indices of
// c encountered breakpoints; and
// c iorder(nfree),...,iorder(n) are indices of variables which
// c have no bound constraits along the search direction.
// c
// c iwhere is an integer array of dimension n.
// c On entry iwhere indicates only the permanently fixed (iwhere=3)
// c or free (iwhere= -1) components of x.
// c On exit iwhere records the status of the current x variables.
// c iwhere(i)=-3 if x(i) is free and has bounds, but is not moved
// c 0 if x(i) is free and has bounds, and is moved
// c 1 if x(i) is fixed at l(i), and l(i) .ne. u(i)
// c 2 if x(i) is fixed at u(i), and u(i) .ne. l(i)
// c 3 if x(i) is always fixed, i.e., u(i)=x(i)=l(i)
// c -1 if x(i) is always free, i.e., it has no bounds.
// c
// c t is a double precision working array of dimension n.
// c t will be used to store the break points.
// c
// c d is a double precision array of dimension n used to store
// c the Cauchy direction P(x-tg)-x.
// c
// c xcp is a double precision array of dimension n used to return the
// c GCP on exit.
// 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 ws, wy, sy, and wt are double precision arrays.
// c On entry they store information that defines 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 sy(m,m) stores S'Y;
// c wt(m,m) stores the
// c Cholesky factorization of (theta*S'S+LD^(-1)L').
// c On exit these arrays are unchanged.
// c
// c theta is a double precision variable.
// c On entry theta is the scaling factor specifying B_0 = theta I.
// c On exit theta is unchanged.
// c
// c col is an integer variable.
// c On entry col is the actual number of variable metric
// c corrections stored so far.
// c On exit col is unchanged.
// c
// c head is an integer variable.
// c On entry head is the location of the first s-vector (or y-vector)
// c in S (or Y).
// c On exit col is unchanged.
// c
// c p is a double precision working array of dimension 2m.
// c p will be used to store the vector p = W^(T)d.
// c
// c c is a double precision working array of dimension 2m.
// c c will be used to store the vector c = W^(T)(xcp-x).
// c
// c wbp is a double precision working array of dimension 2m.
// c wbp will be used to store the row of W corresponding
// c to a breakpoint.
// c
// c v is a double precision working array of dimension 2m.
// c
// c nint is an integer variable.
// c On exit nint records the number of quadratic segments explored
// c in searching for the GCP.
// c
// c sg and yg are double precision arrays of dimension m.
// c On entry sg and yg store S'g and Y'g correspondingly.
// c On exit they are 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 sbgnrm is a double precision variable.
// c On entry sbgnrm is the norm of the projected gradient at x.
// c On exit sbgnrm is unchanged.
// c
// c info is an integer variable.
// c On entry info is 0.
// c On exit info = 0 for normal return,
// c = nonzero for abnormal return when the the system
// c used in routine bmv is singular.
// c
// c Subprograms called:
// c
// c L-BFGS-B Library ... hpsolb, bmv.
// c
// c Linpack ... dscal dcopy, daxpy.
// 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 [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: FORTRAN
// c Subroutines for Large Scale Bound Constrained Optimization''
// c Tech. Report, NAM-11, EECS Department, Northwestern University,
// c 1994.
// c
// c (Postscript files of these papers are available via anonymous
// c ftp to eecs.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.)
// 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 Check the status of the variables, reset iwhere(i) if necessary;
// c compute the Cauchy direction d and the breakpoints t; initialize
// c the derivative f1 and the vector p = W'd (for theta = 1).
#endregion
#region Body
if (SBGNRM <= ZERO)
{
if (IPRINT >= 0)
{
; //ERROR-ERRORWRITE(6,*)'Subgnorm = 0. GCP = X.'
}
this._dcopy.Run(N, X, offset_x, 1, ref XCP, offset_xcp, 1);
return;
}
BNDED = true;
NFREE = N + 1;
NBREAK = 0;
IBKMIN = 0;
BKMIN = ZERO;
COL2 = 2 * COL;
F1 = ZERO;
if (IPRINT >= 99)
{
; //ERROR-ERRORWRITE(6,3010)
}
// c We set p to zero and build it up as we determine d.
for (I = 1; I <= COL2; I++)
{
P[I + o_p] = ZERO;
}
// c In the following loop we determine for each variable its bound
// c status and its breakpoint, and update p accordingly.
// c Smallest breakpoint is identified.
for (I = 1; I <= N; I++)
{
NEGGI = -G[I + o_g];
if (IWHERE[I + o_iwhere] != 3 && IWHERE[I + o_iwhere] != -1)
{
// c if x(i) is not a constant and has bounds,
// c compute the difference between x(i) and its bounds.
if (NBD[I + o_nbd] <= 2)
{
TL = X[I + o_x] - L[I + o_l];
}
if (NBD[I + o_nbd] >= 2)
{
TU = U[I + o_u] - X[I + o_x];
}
// c If a variable is close enough to a bound
// c we treat it as at bound.
XLOWER = NBD[I + o_nbd] <= 2 && TL <= ZERO;
XUPPER = NBD[I + o_nbd] >= 2 && TU <= ZERO;
// c reset iwhere(i).
IWHERE[I + o_iwhere] = 0;
if (XLOWER)
{
if (NEGGI <= ZERO)
{
IWHERE[I + o_iwhere] = 1;
}
}
else
{
if (XUPPER)
{
if (NEGGI >= ZERO)
{
IWHERE[I + o_iwhere] = 2;
}
}
else
{
if (Math.Abs(NEGGI) <= ZERO)
{
IWHERE[I + o_iwhere] = -3;
}
}
}
}
POINTR = HEAD;
if (IWHERE[I + o_iwhere] != 0 && IWHERE[I + o_iwhere] != -1)
{
D[I + o_d] = ZERO;
}
else
{
D[I + o_d] = NEGGI;
F1 += -NEGGI * NEGGI;
// c calculate p := p - W'e_i* (g_i).
for (J = 1; J <= COL; J++)
{
P[J + o_p] += WY[I + POINTR * N + o_wy] * NEGGI;
P[COL + J + o_p] += WS[I + POINTR * N + o_ws] * NEGGI;
POINTR = FortranLib.Mod(POINTR, M) + 1;
}
if (NBD[I + o_nbd] <= 2 && NBD[I + o_nbd] != 0 && NEGGI < ZERO)
{
// c x(i) + d(i) is bounded; compute t(i).
NBREAK += 1;
IORDER[NBREAK + o_iorder] = I;
T[NBREAK + o_t] = TL / (-NEGGI);
if (NBREAK == 1 || T[NBREAK + o_t] < BKMIN)
{
BKMIN = T[NBREAK + o_t];
IBKMIN = NBREAK;
}
}
else
{
if (NBD[I + o_nbd] >= 2 && NEGGI > ZERO)
{
// c x(i) + d(i) is bounded; compute t(i).
NBREAK += 1;
IORDER[NBREAK + o_iorder] = I;
T[NBREAK + o_t] = TU / NEGGI;
if (NBREAK == 1 || T[NBREAK + o_t] < BKMIN)
{
BKMIN = T[NBREAK + o_t];
IBKMIN = NBREAK;
}
}
else
{
// c x(i) + d(i) is not bounded.
NFREE -= 1;
IORDER[NFREE + o_iorder] = I;
if (Math.Abs(NEGGI) > ZERO)
{
BNDED = false;
}
}
}
}
}
// c The indices of the nonzero components of d are now stored
// c in iorder(1),...,iorder(nbreak) and iorder(nfree),...,iorder(n).
// c The smallest of the nbreak breakpoints is in t(ibkmin)=bkmin.
if (THETA != ONE)
{
// c complete the initialization of p for theta not= one.
this._dscal.Run(COL, THETA, ref P, COL + 1 + o_p, 1);
}
// c Initialize GCP xcp = x.
this._dcopy.Run(N, X, offset_x, 1, ref XCP, offset_xcp, 1);
if (NBREAK == 0 && NFREE == N + 1)
{
// c is a zero vector, return with the initial xcp as GCP.
if (IPRINT > 100)
{
; //ERROR-ERRORWRITE(6,1010)(XCP(I),I=1,N)
}
return;
}
// c Initialize c = W'(xcp - x) = 0.
for (J = 1; J <= COL2; J++)
{
C[J + o_c] = ZERO;
}
// c Initialize derivative f2.
F2 = -THETA * F1;
F2_ORG = F2;
if (COL > 0)
{
this._bmv.Run(M, SY, offset_sy, WT, offset_wt, COL, P, offset_p, ref V, offset_v
, ref INFO);
if (INFO != 0)
{
return;
}
F2 -= this._ddot.Run(COL2, V, offset_v, 1, P, offset_p, 1);
}
DTM = -F1 / F2;
TSUM = ZERO;
NINT = 1;
if (IPRINT >= 99)
{
; //ERROR-ERRORWRITE(6,*)'There are ',NBREAK,' breakpoints '
}
// c If there are no breakpoints, locate the GCP and return.
if (NBREAK == 0)
{
goto LABEL888;
}
NLEFT = NBREAK;
ITER = 1;
TJ = ZERO;
// c------------------- the beginning of the loop -------------------------
LABEL777 :;
// c Find the next smallest breakpoint;
// c compute dt = t(nleft) - t(nleft + 1).
TJ0 = TJ;
if (ITER == 1)
{
// c Since we already have the smallest breakpoint we need not do
// c heapsort yet. Often only one breakpoint is used and the
// c cost of heapsort is avoided.
TJ = BKMIN;
IBP = IORDER[IBKMIN + o_iorder];
}
else
{
if (ITER == 2)
{
// c Replace the already used smallest breakpoint with the
// c breakpoint numbered nbreak > nlast, before heapsort call.
if (IBKMIN != NBREAK)
{
T[IBKMIN + o_t] = T[NBREAK + o_t];
IORDER[IBKMIN + o_iorder] = IORDER[NBREAK + o_iorder];
}
// c Update heap structure of breakpoints
// c (if iter=2, initialize heap).
}
this._hpsolb.Run(NLEFT, ref T, offset_t, ref IORDER, offset_iorder, ITER - 2);
TJ = T[NLEFT + o_t];
IBP = IORDER[NLEFT + o_iorder];
}
DT = TJ - TJ0;
if (DT != ZERO && IPRINT >= 100)
{
//ERROR-ERROR WRITE (6,4011) NINT,F1,F2;
//ERROR-ERROR WRITE (6,5010) DT;
//ERROR-ERROR WRITE (6,6010) DTM;
}
// c If a minimizer is within this interval, locate the GCP and return.
if (DTM < DT)
{
goto LABEL888;
}
// c Otherwise fix one variable and
// c reset the corresponding component of d to zero.
TSUM += DT;
NLEFT -= 1;
ITER += 1;
DIBP = D[IBP + o_d];
D[IBP + o_d] = ZERO;
if (DIBP > ZERO)
{
ZIBP = U[IBP + o_u] - X[IBP + o_x];
XCP[IBP + o_xcp] = U[IBP + o_u];
IWHERE[IBP + o_iwhere] = 2;
}
else
{
ZIBP = L[IBP + o_l] - X[IBP + o_x];
XCP[IBP + o_xcp] = L[IBP + o_l];
IWHERE[IBP + o_iwhere] = 1;
}
if (IPRINT >= 100)
{
; //ERROR-ERRORWRITE(6,*)'Variable ',IBP,' is fixed.'
}
if (NLEFT == 0 && NBREAK == N)
{
// c all n variables are fixed,
// c return with xcp as GCP.
DTM = DT;
goto LABEL999;
}
// c Update the derivative information.
NINT += 1;
DIBP2 = Math.Pow(DIBP, 2);
// c Update f1 and f2.
// c temporarily set f1 and f2 for col=0.
F1 += DT * F2 + DIBP2 - THETA * DIBP * ZIBP;
F2 += -THETA * DIBP2;
if (COL > 0)
{
// c update c = c + dt*p.
this._daxpy.Run(COL2, DT, P, offset_p, 1, ref C, offset_c, 1);
// c choose wbp,
// c the row of W corresponding to the breakpoint encountered.
POINTR = HEAD;
for (J = 1; J <= COL; J++)
{
WBP[J + o_wbp] = WY[IBP + POINTR * N + o_wy];
WBP[COL + J + o_wbp] = THETA * WS[IBP + POINTR * N + o_ws];
POINTR = FortranLib.Mod(POINTR, M) + 1;
}
// c compute (wbp)Mc, (wbp)Mp, and (wbp)M(wbp)'.
this._bmv.Run(M, SY, offset_sy, WT, offset_wt, COL, WBP, offset_wbp, ref V, offset_v
, ref INFO);
if (INFO != 0)
{
return;
}
WMC = this._ddot.Run(COL2, C, offset_c, 1, V, offset_v, 1);
WMP = this._ddot.Run(COL2, P, offset_p, 1, V, offset_v, 1);
WMW = this._ddot.Run(COL2, WBP, offset_wbp, 1, V, offset_v, 1);
// c update p = p - dibp*wbp.
this._daxpy.Run(COL2, -DIBP, WBP, offset_wbp, 1, ref P, offset_p, 1);
// c complete updating f1 and f2 while col > 0.
F1 += DIBP * WMC;
F2 += 2.0E0 * DIBP * WMP - DIBP2 * WMW;
}
F2 = Math.Max(EPSMCH * F2_ORG, F2);
if (NLEFT > 0)
{
DTM = -F1 / F2;
goto LABEL777;
// c to repeat the loop for unsearched intervals.
}
else
{
if (BNDED)
{
F1 = ZERO;
F2 = ZERO;
DTM = ZERO;
}
else
{
DTM = -F1 / F2;
}
}
// c------------------- the end of the loop -------------------------------
LABEL888 :;
if (IPRINT >= 99)
{
//ERROR-ERROR WRITE (6,*);
//ERROR-ERROR WRITE (6,*) 'GCP found in this segment';
//ERROR-ERROR WRITE (6,4010) NINT,F1,F2;
//ERROR-ERROR WRITE (6,6010) DTM;
}
if (DTM <= ZERO)
{
DTM = ZERO;
}
TSUM += DTM;
// c Move free variables (i.e., the ones w/o breakpoints) and
// c the variables whose breakpoints haven't been reached.
this._daxpy.Run(N, TSUM, D, offset_d, 1, ref XCP, offset_xcp, 1);
LABEL999 :;
// c Update c = c + dtm*p = W'(x^c - x)
// c which will be used in computing r = Z'(B(x^c - x) + g).
if (COL > 0)
{
this._daxpy.Run(COL2, DTM, P, offset_p, 1, ref C, offset_c, 1);
}
if (IPRINT > 100)
{
; //ERROR-ERRORWRITE(6,1010)(XCP(I),I=1,N)
}
if (IPRINT >= 99)
{
; //ERROR-ERRORWRITE(6,2010)
}
return;
#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
/// =======
///
/// 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
/// =======
///
/// This program sets problem and machine dependent parameters
/// useful for xHSEQR and its subroutines. It is called whenever
/// ILAENV is called with 12 .LE. ISPEC .LE. 16
///
///</summary>
/// <param name="ISPEC">
/// (input) integer scalar
/// ISPEC specifies which tunable parameter IPARMQ should
/// return.
///
/// ISPEC=12: (INMIN) Matrices of order nmin or less
/// are sent directly to xLAHQR, the implicit
/// double shift QR algorithm. NMIN must be
/// at least 11.
///
/// ISPEC=13: (INWIN) Size of the deflation window.
/// This is best set greater than or equal to
/// the number of simultaneous shifts NS.
/// Larger matrices benefit from larger deflation
/// windows.
///
/// ISPEC=14: (INIBL) Determines when to stop nibbling and
/// invest in an (expensive) multi-shift QR sweep.
/// If the aggressive early deflation subroutine
/// finds LD converged eigenvalues from an order
/// NW deflation window and LD.GT.(NW*NIBBLE)/100,
/// then the next QR sweep is skipped and early
/// deflation is applied immediately to the
/// remaining active diagonal block. Setting
/// IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a
/// multi-shift QR sweep whenever early deflation
/// finds a converged eigenvalue. Setting
/// IPARMQ(ISPEC=14) greater than or equal to 100
/// prevents TTQRE from skipping a multi-shift
/// QR sweep.
///
/// ISPEC=15: (NSHFTS) The number of simultaneous shifts in
/// a multi-shift QR iteration.
///
/// ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the
/// following meanings.
/// 0: During the multi-shift QR sweep,
/// xLAQR5 does not accumulate reflections and
/// does not use matrix-matrix multiply to
/// update the far-from-diagonal matrix
/// entries.
/// 1: During the multi-shift QR sweep,
/// xLAQR5 and/or xLAQRaccumulates reflections and uses
/// matrix-matrix multiply to update the
/// far-from-diagonal matrix entries.
/// 2: During the multi-shift QR sweep.
/// xLAQR5 accumulates reflections and takes
/// advantage of 2-by-2 block structure during
/// matrix-matrix multiplies.
/// (If xTRMM is slower than xGEMM, then
/// IPARMQ(ISPEC=16)=1 may be more efficient than
/// IPARMQ(ISPEC=16)=2 despite the greater level of
/// arithmetic work implied by the latter choice.)
///</param>
/// <param name="NAME">
/// (input) character string
/// Name of the calling subroutine
///</param>
/// <param name="OPTS">
/// (input) character string
/// This is a concatenation of the string arguments to
/// TTQRE.
///</param>
/// <param name="N">
/// (input) integer scalar
/// N is the order of the Hessenberg matrix H.
///</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.
///</param>
/// <param name="LWORK">
/// (input) integer scalar
/// The amount of workspace available.
///</param>
public int Run(int ISPEC, string NAME, string OPTS, int N, int ILO, int IHI
, int LWORK)
{
int iparmq = 0;
#region Variables
int NH = 0; int NS = 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
// * =======
// *
// * This program sets problem and machine dependent parameters
// * useful for xHSEQR and its subroutines. It is called whenever
// * ILAENV is called with 12 <= ISPEC <= 16
// *
// * Arguments
// * =========
// *
// * ISPEC (input) integer scalar
// * ISPEC specifies which tunable parameter IPARMQ should
// * return.
// *
// * ISPEC=12: (INMIN) Matrices of order nmin or less
// * are sent directly to xLAHQR, the implicit
// * double shift QR algorithm. NMIN must be
// * at least 11.
// *
// * ISPEC=13: (INWIN) Size of the deflation window.
// * This is best set greater than or equal to
// * the number of simultaneous shifts NS.
// * Larger matrices benefit from larger deflation
// * windows.
// *
// * ISPEC=14: (INIBL) Determines when to stop nibbling and
// * invest in an (expensive) multi-shift QR sweep.
// * If the aggressive early deflation subroutine
// * finds LD converged eigenvalues from an order
// * NW deflation window and LD.GT.(NW*NIBBLE)/100,
// * then the next QR sweep is skipped and early
// * deflation is applied immediately to the
// * remaining active diagonal block. Setting
// * IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a
// * multi-shift QR sweep whenever early deflation
// * finds a converged eigenvalue. Setting
// * IPARMQ(ISPEC=14) greater than or equal to 100
// * prevents TTQRE from skipping a multi-shift
// * QR sweep.
// *
// * ISPEC=15: (NSHFTS) The number of simultaneous shifts in
// * a multi-shift QR iteration.
// *
// * ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the
// * following meanings.
// * 0: During the multi-shift QR sweep,
// * xLAQR5 does not accumulate reflections and
// * does not use matrix-matrix multiply to
// * update the far-from-diagonal matrix
// * entries.
// * 1: During the multi-shift QR sweep,
// * xLAQR5 and/or xLAQRaccumulates reflections and uses
// * matrix-matrix multiply to update the
// * far-from-diagonal matrix entries.
// * 2: During the multi-shift QR sweep.
// * xLAQR5 accumulates reflections and takes
// * advantage of 2-by-2 block structure during
// * matrix-matrix multiplies.
// * (If xTRMM is slower than xGEMM, then
// * IPARMQ(ISPEC=16)=1 may be more efficient than
// * IPARMQ(ISPEC=16)=2 despite the greater level of
// * arithmetic work implied by the latter choice.)
// *
// * NAME (input) character string
// * Name of the calling subroutine
// *
// * OPTS (input) character string
// * This is a concatenation of the string arguments to
// * TTQRE.
// *
// * N (input) integer scalar
// * N is the order of the Hessenberg matrix H.
// *
// * 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.
// *
// * LWORK (input) integer scalar
// * The amount of workspace available.
// *
// * Further Details
// * ===============
// *
// * Little is known about how best to choose these parameters.
// * It is possible to use different values of the parameters
// * for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR.
// *
// * It is probably best to choose different parameters for
// * different matrices and different parameters at different
// * times during the iteration, but this has not been
// * implemented --- yet.
// *
// *
// * The best choices of most of the parameters depend
// * in an ill-understood way on the relative execution
// * rate of xLAQR3 and xLAQR5 and on the nature of each
// * particular eigenvalue problem. Experiment may be the
// * only practical way to determine which choices are most
// * effective.
// *
// * Following is a list of default values supplied by IPARMQ.
// * These defaults may be adjusted in order to attain better
// * performance in any particular computational environment.
// *
// * IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point.
// * Default: 75. (Must be at least 11.)
// *
// * IPARMQ(ISPEC=13) Recommended deflation window size.
// * This depends on ILO, IHI and NS, the
// * number of simultaneous shifts returned
// * by IPARMQ(ISPEC=15). The default for
// * (IHI-ILO+1).LE.500 is NS. The default
// * for (IHI-ILO+1).GT.500 is 3*NS/2.
// *
// * IPARMQ(ISPEC=14) Nibble crossover point. Default: 14.
// *
// * IPARMQ(ISPEC=15) Number of simultaneous shifts, NS.
// * a multi-shift QR iteration.
// *
// * If IHI-ILO+1 is ...
// *
// * greater than ...but less ... the
// * or equal to ... than default is
// *
// * 0 30 NS = 2+
// * 30 60 NS = 4+
// * 60 150 NS = 10
// * 150 590 NS = **
// * 590 3000 NS = 64
// * 3000 6000 NS = 128
// * 6000 infinity NS = 256
// *
// * (+) By default matrices of this order are
// * passed to the implicit double shift routine
// * xLAHQR. See IPARMQ(ISPEC=12) above. These
// * values of NS are used only in case of a rare
// * xLAHQR failure.
// *
// * (**) The asterisks (**) indicate an ad-hoc
// * function increasing from 10 to 64.
// *
// * IPARMQ(ISPEC=16) Select structured matrix multiply.
// * (See ISPEC=16 above for details.)
// * Default: 3.
// *
// * ================================================================
// * .. Parameters ..
// * ..
// * .. Local Scalars ..
// * ..
// * .. Intrinsic Functions ..
// INTRINSIC LOG, MAX, MOD, NINT, REAL;
// * ..
// * .. Executable Statements ..
#endregion
#region Body
if ((ISPEC == ISHFTS) || (ISPEC == INWIN) || (ISPEC == IACC22))
{
// *
// * ==== Set the number simultaneous shifts ====
// *
NH = IHI - ILO + 1;
NS = 2;
if (NH >= 30)
{
NS = 4;
}
if (NH >= 60)
{
NS = 10;
}
if (NH >= 150)
{
NS = (int)Math.Max(10, NH / Math.Round(Math.Log(Convert.ToSingle(NH)) / Math.Log(TWO)));
}
if (NH >= 590)
{
NS = 64;
}
if (NH >= 3000)
{
NS = 128;
}
if (NH >= 6000)
{
NS = 256;
}
NS = Math.Max(2, NS - FortranLib.Mod(NS, 2));
}
// *
if (ISPEC == INMIN)
{
// *
// *
// * ===== Matrices of order smaller than NMIN get sent
// * . to xLAHQR, the classic double shift algorithm.
// * . This must be at least 11. ====
// *
iparmq = NMIN;
// *
}
else
{
if (ISPEC == INIBL)
{
// *
// * ==== INIBL: skip a multi-shift qr iteration and
// * . whenever aggressive early deflation finds
// * . at least (NIBBLE*(window size)/100) deflations. ====
// *
iparmq = NIBBLE;
// *
}
else
{
if (ISPEC == ISHFTS)
{
// *
// * ==== NSHFTS: The number of simultaneous shifts =====
// *
iparmq = NS;
// *
}
else
{
if (ISPEC == INWIN)
{
// *
// * ==== NW: deflation window size. ====
// *
if (NH <= KNWSWP)
{
iparmq = NS;
}
else
{
iparmq = 3 * NS / 2;
}
// *
}
else
{
if (ISPEC == IACC22)
{
// *
// * ==== IACC22: Whether to accumulate reflections
// * . before updating the far-from-diagonal elements
// * . and whether to use 2-by-2 block structure while
// * . doing it. A small amount of work could be saved
// * . by making this choice dependent also upon the
// * . NH=IHI-ILO+1.
// *
iparmq = 0;
if (NS >= KACMIN)
{
iparmq = 1;
}
if (NS >= K22MIN)
{
iparmq = 2;
}
// *
}
else
{
// * ===== invalid value of ispec =====
iparmq = -1;
// *
}
}
}
}
}
// *
// * ==== End of IPARMQ ====
// *
return(iparmq);
#endregion
}