abdelrahman/agent_compositor_test
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
bbe5fcdf4c203db67e409092d067c76e3b397dac
agent_compositor_test/references/igraph-1.0.1/vendor/lapack/dtrsen.c
T
Abdelrahman Said a11edf0c53 Add graph references
2026-06-28 13:49:01 +01:00

624 lines
20 KiB
C
Raw Blame History

/* -- translated by f2c (version 20240504).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#include "f2c.h"
/* Table of constant values */
static integer c_n1 = -1;
/* > \brief \b DTRSEN
=========== DOCUMENTATION ===========
Online html documentation available at
http://www.netlib.org/lapack/explore-html/
> \htmlonly
> Download DTRSEN + dependencies
> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dtrsen.
f">
> [TGZ]</a>
> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dtrsen.
f">
> [ZIP]</a>
> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dtrsen.
f">
> [TXT]</a>
> \endhtmlonly
Definition:
===========
SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI,
M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )
CHARACTER COMPQ, JOB
INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N
DOUBLE PRECISION S, SEP
LOGICAL SELECT( * )
INTEGER IWORK( * )
DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ),
$ WR( * )
> \par Purpose:
=============
>
> \verbatim
>
> DTRSEN reorders the real Schur factorization of a real matrix
> A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in
> the leading diagonal blocks of the upper quasi-triangular matrix T,
> and the leading columns of Q form an orthonormal basis of the
> corresponding right invariant subspace.
>
> Optionally the routine computes the reciprocal condition numbers of
> the cluster of eigenvalues and/or the invariant subspace.
>
> T must be in Schur canonical form (as returned by DHSEQR), that is,
> block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
> 2-by-2 diagonal block has its diagonal elements equal and its
> off-diagonal elements of opposite sign.
> \endverbatim
Arguments:
==========
> \param[in] JOB
> \verbatim
> JOB is CHARACTER*1
> Specifies whether condition numbers are required for the
> cluster of eigenvalues (S) or the invariant subspace (SEP):
> = 'N': none;
> = 'E': for eigenvalues only (S);
> = 'V': for invariant subspace only (SEP);
> = 'B': for both eigenvalues and invariant subspace (S and
> SEP).
> \endverbatim
>
> \param[in] COMPQ
> \verbatim
> COMPQ is CHARACTER*1
> = 'V': update the matrix Q of Schur vectors;
> = 'N': do not update Q.
> \endverbatim
>
> \param[in] SELECT
> \verbatim
> SELECT is LOGICAL array, dimension (N)
> SELECT specifies the eigenvalues in the selected cluster. To
> select a real eigenvalue w(j), SELECT(j) must be set to
> .TRUE.. To select a complex conjugate pair of eigenvalues
> w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
> either SELECT(j) or SELECT(j+1) or both must be set to
> .TRUE.; a complex conjugate pair of eigenvalues must be
> either both included in the cluster or both excluded.
> \endverbatim
>
> \param[in] N
> \verbatim
> N is INTEGER
> The order of the matrix T. N >= 0.
> \endverbatim
>
> \param[in,out] T
> \verbatim
> T is DOUBLE PRECISION array, dimension (LDT,N)
> On entry, the upper quasi-triangular matrix T, in Schur
> canonical form.
> On exit, T is overwritten by the reordered matrix T, again in
> Schur canonical form, with the selected eigenvalues in the
> leading diagonal blocks.
> \endverbatim
>
> \param[in] LDT
> \verbatim
> LDT is INTEGER
> The leading dimension of the array T. LDT >= max(1,N).
> \endverbatim
>
> \param[in,out] Q
> \verbatim
> Q is DOUBLE PRECISION array, dimension (LDQ,N)
> On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
> On exit, if COMPQ = 'V', Q has been postmultiplied by the
> orthogonal transformation matrix which reorders T; the
> leading M columns of Q form an orthonormal basis for the
> specified invariant subspace.
> If COMPQ = 'N', Q is not referenced.
> \endverbatim
>
> \param[in] LDQ
> \verbatim
> LDQ is INTEGER
> The leading dimension of the array Q.
> LDQ >= 1; and if COMPQ = 'V', LDQ >= N.
> \endverbatim
>
> \param[out] WR
> \verbatim
> WR is DOUBLE PRECISION array, dimension (N)
> \endverbatim
> \param[out] WI
> \verbatim
> WI is DOUBLE PRECISION array, dimension (N)
>
> The real and imaginary parts, respectively, of the reordered
> eigenvalues of T. The eigenvalues are stored in the same
> order as on the diagonal of T, with WR(i) = T(i,i) and, if
> T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and
> WI(i+1) = -WI(i). Note that if a complex eigenvalue is
> sufficiently ill-conditioned, then its value may differ
> significantly from its value before reordering.
> \endverbatim
>
> \param[out] M
> \verbatim
> M is INTEGER
> The dimension of the specified invariant subspace.
> 0 < = M <= N.
> \endverbatim
>
> \param[out] S
> \verbatim
> S is DOUBLE PRECISION
> If JOB = 'E' or 'B', S is a lower bound on the reciprocal
> condition number for the selected cluster of eigenvalues.
> S cannot underestimate the true reciprocal condition number
> by more than a factor of sqrt(N). If M = 0 or N, S = 1.
> If JOB = 'N' or 'V', S is not referenced.
> \endverbatim
>
> \param[out] SEP
> \verbatim
> SEP is DOUBLE PRECISION
> If JOB = 'V' or 'B', SEP is the estimated reciprocal
> condition number of the specified invariant subspace. If
> M = 0 or N, SEP = norm(T).
> If JOB = 'N' or 'E', SEP is not referenced.
> \endverbatim
>
> \param[out] WORK
> \verbatim
> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
> \endverbatim
>
> \param[in] LWORK
> \verbatim
> LWORK is INTEGER
> The dimension of the array WORK.
> If JOB = 'N', LWORK >= max(1,N);
> if JOB = 'E', LWORK >= max(1,M*(N-M));
> if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).
>
> 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.
> \endverbatim
>
> \param[out] IWORK
> \verbatim
> IWORK is INTEGER array, dimension (MAX(1,LIWORK))
> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
> \endverbatim
>
> \param[in] LIWORK
> \verbatim
> LIWORK is INTEGER
> The dimension of the array IWORK.
> If JOB = 'N' or 'E', LIWORK >= 1;
> if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)).
>
> 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.
> \endverbatim
>
> \param[out] INFO
> \verbatim
> INFO is INTEGER
> = 0: successful exit
> < 0: if INFO = -i, the i-th argument had an illegal value
> = 1: reordering of T failed because some eigenvalues are too
> close to separate (the problem is very ill-conditioned);
> T may have been partially reordered, and WR and WI
> contain the eigenvalues in the same order as in T; S and
> SEP (if requested) are set to zero.
> \endverbatim
Authors:
========
> \author Univ. of Tennessee
> \author Univ. of California Berkeley
> \author Univ. of Colorado Denver
> \author NAG Ltd.
> \date April 2012
> \ingroup doubleOTHERcomputational
> \par Further Details:
=====================
>
> \verbatim
>
> DTRSEN first collects the selected eigenvalues by computing an
> orthogonal transformation Z to move them to the top left corner of T.
> In other words, the selected eigenvalues are the eigenvalues of T11
> in:
>
> Z**T * T * Z = ( T11 T12 ) n1
> ( 0 T22 ) n2
> n1 n2
>
> where N = n1+n2 and Z**T means the transpose of Z. The first n1 columns
> of Z span the specified invariant subspace of T.
>
> If T has been obtained from the real Schur factorization of a matrix
> A = Q*T*Q**T, then the reordered real Schur factorization of A is given
> by A = (Q*Z)*(Z**T*T*Z)*(Q*Z)**T, and the first n1 columns of Q*Z span
> the corresponding invariant subspace of A.
>
> The reciprocal condition number of the average of the eigenvalues of
> T11 may be returned in S. S lies between 0 (very badly conditioned)
> and 1 (very well conditioned). It is computed as follows. First we
> compute R so that
>
> P = ( I R ) n1
> ( 0 0 ) n2
> n1 n2
>
> is the projector on the invariant subspace associated with T11.
> R is the solution of the Sylvester equation:
>
> T11*R - R*T22 = T12.
>
> Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
> the two-norm of M. Then S is computed as the lower bound
>
> (1 + F-norm(R)**2)**(-1/2)
>
> on the reciprocal of 2-norm(P), the true reciprocal condition number.
> S cannot underestimate 1 / 2-norm(P) by more than a factor of
> sqrt(N).
>
> An approximate error bound for the computed average of the
> eigenvalues of T11 is
>
> EPS * norm(T) / S
>
> where EPS is the machine precision.
>
> The reciprocal condition number of the right invariant subspace
> spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
> SEP is defined as the separation of T11 and T22:
>
> sep( T11, T22 ) = sigma-min( C )
>
> where sigma-min(C) is the smallest singular value of the
> n1*n2-by-n1*n2 matrix
>
> C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
>
> I(m) is an m by m identity matrix, and kprod denotes the Kronecker
> product. We estimate sigma-min(C) by the reciprocal of an estimate of
> the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
> cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
>
> When SEP is small, small changes in T can cause large changes in
> the invariant subspace. An approximate bound on the maximum angular
> error in the computed right invariant subspace is
>
> EPS * norm(T) / SEP
> \endverbatim
>
=====================================================================
Subroutine */ int igraphdtrsen_(char *job, char *compq, logical *select, integer
*n, doublereal *t, integer *ldt, doublereal *q, integer *ldq,
doublereal *wr, doublereal *wi, integer *m, doublereal *s, doublereal
*sep, doublereal *work, integer *lwork, integer *iwork, integer *
liwork, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer k, n1, n2, kk, nn, ks;
doublereal est;
integer kase;
logical pair;
integer ierr;
logical swap;
doublereal scale;
extern logical igraphlsame_(char *, char *);
integer isave[3], lwmin;
logical wantq, wants;
doublereal rnorm;
extern /* Subroutine */ int igraphdlacn2_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
extern doublereal igraphdlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int igraphdlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
igraphxerbla_(char *, integer *, ftnlen);
logical wantbh;
extern /* Subroutine */ int igraphdtrexc_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *,
doublereal *, integer *);
integer liwmin;
logical wantsp, lquery;
extern /* Subroutine */ int igraphdtrsyl_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *);
/* -- LAPACK computational routine (version 3.4.1) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
April 2012
=====================================================================
Decode and test the input parameters
Parameter adjustments */
--select;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--wr;
--wi;
--work;
--iwork;
/* Function Body */
wantbh = igraphlsame_(job, "B");
wants = igraphlsame_(job, "E") || wantbh;
wantsp = igraphlsame_(job, "V") || wantbh;
wantq = igraphlsame_(compq, "V");
*info = 0;
lquery = *lwork == -1;
if (! igraphlsame_(job, "N") && ! wants && ! wantsp) {
*info = -1;
} else if (! igraphlsame_(compq, "N") && ! wantq) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1,*n)) {
*info = -6;
} else if (*ldq < 1 || wantq && *ldq < *n) {
*info = -8;
} else {
/* Set M to the dimension of the specified invariant subspace,
and test LWORK and LIWORK. */
*m = 0;
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (pair) {
pair = FALSE_;
} else {
if (k < *n) {
if (t[k + 1 + k * t_dim1] == 0.) {
if (select[k]) {
++(*m);
}
} else {
pair = TRUE_;
if (select[k] || select[k + 1]) {
*m += 2;
}
}
} else {
if (select[*n]) {
++(*m);
}
}
}
/* L10: */
}
n1 = *m;
n2 = *n - *m;
nn = n1 * n2;
if (wantsp) {
/* Computing MAX */
i__1 = 1, i__2 = nn << 1;
lwmin = max(i__1,i__2);
liwmin = max(1,nn);
} else if (igraphlsame_(job, "N")) {
lwmin = max(1,*n);
liwmin = 1;
} else if (igraphlsame_(job, "E")) {
lwmin = max(1,nn);
liwmin = 1;
}
if (*lwork < lwmin && ! lquery) {
*info = -15;
} else if (*liwork < liwmin && ! lquery) {
*info = -17;
}
}
if (*info == 0) {
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DTRSEN", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible. */
if (*m == *n || *m == 0) {
if (wants) {
*s = 1.;
}
if (wantsp) {
*sep = igraphdlange_("1", n, n, &t[t_offset], ldt, &work[1]);
}
goto L40;
}
/* Collect the selected blocks at the top-left corner of T. */
ks = 0;
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (pair) {
pair = FALSE_;
} else {
swap = select[k];
if (k < *n) {
if (t[k + 1 + k * t_dim1] != 0.) {
pair = TRUE_;
swap = swap || select[k + 1];
}
}
if (swap) {
++ks;
/* Swap the K-th block to position KS. */
ierr = 0;
kk = k;
if (k != ks) {
igraphdtrexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
kk, &ks, &work[1], &ierr);
}
if (ierr == 1 || ierr == 2) {
/* Blocks too close to swap: exit. */
*info = 1;
if (wants) {
*s = 0.;
}
if (wantsp) {
*sep = 0.;
}
goto L40;
}
if (pair) {
++ks;
}
}
}
/* L20: */
}
if (wants) {
/* Solve Sylvester equation for R:
T11*R - R*T22 = scale*T12 */
igraphdlacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1);
igraphdtrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1
+ 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr);
/* Estimate the reciprocal of the condition number of the cluster
of eigenvalues. */
rnorm = igraphdlange_("F", &n1, &n2, &work[1], &n1, &work[1]);
if (rnorm == 0.) {
*s = 1.;
} else {
*s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm));
}
}
if (wantsp) {
/* Estimate sep(T11,T22). */
est = 0.;
kase = 0;
L30:
igraphdlacn2_(&nn, &work[nn + 1], &work[1], &iwork[1], &est, &kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Solve T11*R - R*T22 = scale*X. */
igraphdtrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
ierr);
} else {
/* Solve T11**T*R - R*T22**T = scale*X. */
igraphdtrsyl_("T", "T", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
ierr);
}
goto L30;
}
*sep = scale / est;
}
L40:
/* Store the output eigenvalues in WR and WI. */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
wr[k] = t[k + k * t_dim1];
wi[k] = 0.;
/* L50: */
}
i__1 = *n - 1;
for (k = 1; k <= i__1; ++k) {
if (t[k + 1 + k * t_dim1] != 0.) {
wi[k] = sqrt((d__1 = t[k + (k + 1) * t_dim1], abs(d__1))) * sqrt((
d__2 = t[k + 1 + k * t_dim1], abs(d__2)));
wi[k + 1] = -wi[k];
}
/* L60: */
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
return 0;
/* End of DTRSEN */
} /* igraphdtrsen_ */
Reference in New Issue View Git Blame Copy Permalink