/src/igraph/vendor/lapack/dtrexc.c

Source (jump to first uncovered line)
/*  -- translated by f2c (version 20191129).
   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__1 = 1;
static integer c__2 = 2;

/* > \brief \b DTREXC   

    =========== DOCUMENTATION ===========   

   Online html documentation available at   
              http://www.netlib.org/lapack/explore-html/   

   > \htmlonly   
   > Download DTREXC + dependencies   
   > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dtrexc.
f">   
   > [TGZ]</a>   
   > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dtrexc.
f">   
   > [ZIP]</a>   
   > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dtrexc.
f">   
   > [TXT]</a>   
   > \endhtmlonly   

    Definition:   
    ===========   

         SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK,   
                            INFO )   

         CHARACTER          COMPQ   
         INTEGER            IFST, ILST, INFO, LDQ, LDT, N   
         DOUBLE PRECISION   Q( LDQ, * ), T( LDT, * ), WORK( * )   


   > \par Purpose:   
    =============   
   >   
   > \verbatim   
   >   
   > DTREXC reorders the real Schur factorization of a real matrix   
   > A = Q*T*Q**T, so that the diagonal block of T with row index IFST is   
   > moved to row ILST.   
   >   
   > The real Schur form T is reordered by an orthogonal similarity   
   > transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors   
   > is updated by postmultiplying it with Z.   
   >   
   > 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] COMPQ   
   > \verbatim   
   >          COMPQ is CHARACTER*1   
   >          = 'V':  update the matrix Q of Schur vectors;   
   >          = 'N':  do not update Q.   
   > \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   
   >          Schur canonical form.   
   >          On exit, the reordered upper quasi-triangular matrix, again   
   >          in Schur canonical form.   
   > \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 Z which reorders T.   
   >          If COMPQ = 'N', Q is not referenced.   
   > \endverbatim   
   >   
   > \param[in] LDQ   
   > \verbatim   
   >          LDQ is INTEGER   
   >          The leading dimension of the array Q.  LDQ >= max(1,N).   
   > \endverbatim   
   >   
   > \param[in,out] IFST   
   > \verbatim   
   >          IFST is INTEGER   
   > \endverbatim   
   >   
   > \param[in,out] ILST   
   > \verbatim   
   >          ILST is INTEGER   
   >   
   >          Specify the reordering of the diagonal blocks of T.   
   >          The block with row index IFST is moved to row ILST, by a   
   >          sequence of transpositions between adjacent blocks.   
   >          On exit, if IFST pointed on entry to the second row of a   
   >          2-by-2 block, it is changed to point to the first row; ILST   
   >          always points to the first row of the block in its final   
   >          position (which may differ from its input value by +1 or -1).   
   >          1 <= IFST <= N; 1 <= ILST <= N.   
   > \endverbatim   
   >   
   > \param[out] WORK   
   > \verbatim   
   >          WORK is DOUBLE PRECISION array, dimension (N)   
   > \endverbatim   
   >   
   > \param[out] INFO   
   > \verbatim   
   >          INFO is INTEGER   
   >          = 0:  successful exit   
   >          < 0:  if INFO = -i, the i-th argument had an illegal value   
   >          = 1:  two adjacent blocks were too close to swap (the problem   
   >                is very ill-conditioned); T may have been partially   
   >                reordered, and ILST points to the first row of the   
   >                current position of the block being moved.   
   > \endverbatim   

    Authors:   
    ========   

   > \author Univ. of Tennessee   
   > \author Univ. of California Berkeley   
   > \author Univ. of Colorado Denver   
   > \author NAG Ltd.   

   > \date November 2011   

   > \ingroup doubleOTHERcomputational   

    =====================================================================   
   Subroutine */ int igraphdtrexc_(char *compq, integer *n, doublereal *t, integer *
  ldt, doublereal *q, integer *ldq, integer *ifst, integer *ilst, 
  doublereal *work, integer *info)
{
    /* System generated locals */
    integer q_dim1, q_offset, t_dim1, t_offset, i__1;

    /* Local variables */
    integer nbf, nbl, here;
    extern logical igraphlsame_(char *, char *);
    logical wantq;
    extern /* Subroutine */ int igraphdlaexc_(logical *, integer *, doublereal *, 
      integer *, doublereal *, integer *, integer *, integer *, integer 
      *, doublereal *, integer *), igraphxerbla_(char *, integer *, ftnlen);
    integer nbnext;


/*  -- LAPACK computational routine (version 3.4.0) --   
    -- LAPACK is a software package provided by Univ. of Tennessee,    --   
    -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--   
       November 2011   


    =====================================================================   


       Decode and test the input arguments.   

       Parameter adjustments */
    t_dim1 = *ldt;
    t_offset = 1 + t_dim1;
    t -= t_offset;
    q_dim1 = *ldq;
    q_offset = 1 + q_dim1;
    q -= q_offset;
    --work;

    /* Function Body */
    *info = 0;
    wantq = igraphlsame_(compq, "V");
    if (! wantq && ! igraphlsame_(compq, "N")) {
  *info = -1;
    } else if (*n < 0) {
  *info = -2;
    } else if (*ldt < max(1,*n)) {
  *info = -4;
    } else if (*ldq < 1 || wantq && *ldq < max(1,*n)) {
  *info = -6;
    } else if (*ifst < 1 || *ifst > *n) {
  *info = -7;
    } else if (*ilst < 1 || *ilst > *n) {
  *info = -8;
    }
    if (*info != 0) {
  i__1 = -(*info);
  igraphxerbla_("DTREXC", &i__1, (ftnlen)6);
  return 0;
    }

/*     Quick return if possible */

    if (*n <= 1) {
  return 0;
    }

/*     Determine the first row of specified block   
       and find out it is 1 by 1 or 2 by 2. */

    if (*ifst > 1) {
  if (t[*ifst + (*ifst - 1) * t_dim1] != 0.) {
      --(*ifst);
  }
    }
    nbf = 1;
    if (*ifst < *n) {
  if (t[*ifst + 1 + *ifst * t_dim1] != 0.) {
      nbf = 2;
  }
    }

/*     Determine the first row of the final block   
       and find out it is 1 by 1 or 2 by 2. */

    if (*ilst > 1) {
  if (t[*ilst + (*ilst - 1) * t_dim1] != 0.) {
      --(*ilst);
  }
    }
    nbl = 1;
    if (*ilst < *n) {
  if (t[*ilst + 1 + *ilst * t_dim1] != 0.) {
      nbl = 2;
  }
    }

    if (*ifst == *ilst) {
  return 0;
    }

    if (*ifst < *ilst) {

/*        Update ILST */

  if (nbf == 2 && nbl == 1) {
      --(*ilst);
  }
  if (nbf == 1 && nbl == 2) {
      ++(*ilst);
  }

  here = *ifst;

L10:

/*        Swap block with next one below */

  if (nbf == 1 || nbf == 2) {

/*           Current block either 1 by 1 or 2 by 2 */

      nbnext = 1;
      if (here + nbf + 1 <= *n) {
    if (t[here + nbf + 1 + (here + nbf) * t_dim1] != 0.) {
        nbnext = 2;
    }
      }
      igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &here, &
        nbf, &nbnext, &work[1], info);
      if (*info != 0) {
    *ilst = here;
    return 0;
      }
      here += nbnext;

/*           Test if 2 by 2 block breaks into two 1 by 1 blocks */

      if (nbf == 2) {
    if (t[here + 1 + here * t_dim1] == 0.) {
        nbf = 3;
    }
      }

  } else {

/*           Current block consists of two 1 by 1 blocks each of which   
             must be swapped individually */

      nbnext = 1;
      if (here + 3 <= *n) {
    if (t[here + 3 + (here + 2) * t_dim1] != 0.) {
        nbnext = 2;
    }
      }
      i__1 = here + 1;
      igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &
        c__1, &nbnext, &work[1], info);
      if (*info != 0) {
    *ilst = here;
    return 0;
      }
      if (nbnext == 1) {

/*              Swap two 1 by 1 blocks, no problems possible */

    igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
      here, &c__1, &nbnext, &work[1], info);
    ++here;
      } else {

/*              Recompute NBNEXT in case 2 by 2 split */

    if (t[here + 2 + (here + 1) * t_dim1] == 0.) {
        nbnext = 1;
    }
    if (nbnext == 2) {

/*                 2 by 2 Block did not split */

        igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
          here, &c__1, &nbnext, &work[1], info);
        if (*info != 0) {
      *ilst = here;
      return 0;
        }
        here += 2;
    } else {

/*                 2 by 2 Block did split */

        igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
          here, &c__1, &c__1, &work[1], info);
        i__1 = here + 1;
        igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
          i__1, &c__1, &c__1, &work[1], info);
        here += 2;
    }
      }
  }
  if (here < *ilst) {
      goto L10;
  }

    } else {

  here = *ifst;
L20:

/*        Swap block with next one above */

  if (nbf == 1 || nbf == 2) {

/*           Current block either 1 by 1 or 2 by 2 */

      nbnext = 1;
      if (here >= 3) {
    if (t[here - 1 + (here - 2) * t_dim1] != 0.) {
        nbnext = 2;
    }
      }
      i__1 = here - nbnext;
      igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &
        nbnext, &nbf, &work[1], info);
      if (*info != 0) {
    *ilst = here;
    return 0;
      }
      here -= nbnext;

/*           Test if 2 by 2 block breaks into two 1 by 1 blocks */

      if (nbf == 2) {
    if (t[here + 1 + here * t_dim1] == 0.) {
        nbf = 3;
    }
      }

  } else {

/*           Current block consists of two 1 by 1 blocks each of which   
             must be swapped individually */

      nbnext = 1;
      if (here >= 3) {
    if (t[here - 1 + (here - 2) * t_dim1] != 0.) {
        nbnext = 2;
    }
      }
      i__1 = here - nbnext;
      igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &
        nbnext, &c__1, &work[1], info);
      if (*info != 0) {
    *ilst = here;
    return 0;
      }
      if (nbnext == 1) {

/*              Swap two 1 by 1 blocks, no problems possible */

    igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
      here, &nbnext, &c__1, &work[1], info);
    --here;
      } else {

/*              Recompute NBNEXT in case 2 by 2 split */

    if (t[here + (here - 1) * t_dim1] == 0.) {
        nbnext = 1;
    }
    if (nbnext == 2) {

/*                 2 by 2 Block did not split */

        i__1 = here - 1;
        igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
          i__1, &c__2, &c__1, &work[1], info);
        if (*info != 0) {
      *ilst = here;
      return 0;
        }
        here += -2;
    } else {

/*                 2 by 2 Block did split */

        igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
          here, &c__1, &c__1, &work[1], info);
        i__1 = here - 1;
        igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
          i__1, &c__1, &c__1, &work[1], info);
        here += -2;
    }
      }
  }
  if (here > *ilst) {
      goto L20;
  }
    }
    *ilst = here;

    return 0;

/*     End of DTREXC */

} /* igraphdtrexc_ */


Coverage Report

Created: 2023-06-07 06:06

Line	Count	Source (jump to first uncovered line)
1		/* -- translated by f2c (version 20191129).
2		You must link the resulting object file with libf2c:
3		on Microsoft Windows system, link with libf2c.lib;
4		on Linux or Unix systems, link with .../path/to/libf2c.a -lm
5		or, if you install libf2c.a in a standard place, with -lf2c -lm
6		-- in that order, at the end of the command line, as in
7		cc *.o -lf2c -lm
8		Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
9
10		http://www.netlib.org/f2c/libf2c.zip
11		*/
12
13		#include "f2c.h"
14
15		/* Table of constant values */
16
17		static integer c__1 = 1;
18		static integer c__2 = 2;
19
20		/* > \brief \b DTREXC
21
22		=========== DOCUMENTATION ===========
23
24		Online html documentation available at
25		http://www.netlib.org/lapack/explore-html/
26
27		> \htmlonly
28		> Download DTREXC + dependencies
29		> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dtrexc.
30		f">
31		> [TGZ]</a>
32		> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dtrexc.
33		f">
34		> [ZIP]</a>
35		> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dtrexc.
36		f">
37		> [TXT]</a>
38		> \endhtmlonly
39
40		Definition:
41		===========
42
43		SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK,
44		INFO )
45
46		CHARACTER COMPQ
47		INTEGER IFST, ILST, INFO, LDQ, LDT, N
48		DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * )
49
50
51		> \par Purpose:
52		=============
53		>
54		> \verbatim
55		>
56		> DTREXC reorders the real Schur factorization of a real matrix
57		> A = QTQ**T, so that the diagonal block of T with row index IFST is
58		> moved to row ILST.
59		>
60		> The real Schur form T is reordered by an orthogonal similarity
61		> transformation Z*TT*Z, and optionally the matrix Q of Schur vectors
62		> is updated by postmultiplying it with Z.
63		>
64		> T must be in Schur canonical form (as returned by DHSEQR), that is,
65		> block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
66		> 2-by-2 diagonal block has its diagonal elements equal and its
67		> off-diagonal elements of opposite sign.
68		> \endverbatim
69
70		Arguments:
71		==========
72
73		> \param[in] COMPQ
74		> \verbatim
75		> COMPQ is CHARACTER*1
76		> = 'V': update the matrix Q of Schur vectors;
77		> = 'N': do not update Q.
78		> \endverbatim
79		>
80		> \param[in] N
81		> \verbatim
82		> N is INTEGER
83		> The order of the matrix T. N >= 0.
84		> \endverbatim
85		>
86		> \param[in,out] T
87		> \verbatim
88		> T is DOUBLE PRECISION array, dimension (LDT,N)
89		> On entry, the upper quasi-triangular matrix T, in Schur
90		> Schur canonical form.
91		> On exit, the reordered upper quasi-triangular matrix, again
92		> in Schur canonical form.
93		> \endverbatim
94		>
95		> \param[in] LDT
96		> \verbatim
97		> LDT is INTEGER
98		> The leading dimension of the array T. LDT >= max(1,N).
99		> \endverbatim
100		>
101		> \param[in,out] Q
102		> \verbatim
103		> Q is DOUBLE PRECISION array, dimension (LDQ,N)
104		> On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
105		> On exit, if COMPQ = 'V', Q has been postmultiplied by the
106		> orthogonal transformation matrix Z which reorders T.
107		> If COMPQ = 'N', Q is not referenced.
108		> \endverbatim
109		>
110		> \param[in] LDQ
111		> \verbatim
112		> LDQ is INTEGER
113		> The leading dimension of the array Q. LDQ >= max(1,N).
114		> \endverbatim
115		>
116		> \param[in,out] IFST
117		> \verbatim
118		> IFST is INTEGER
119		> \endverbatim
120		>
121		> \param[in,out] ILST
122		> \verbatim
123		> ILST is INTEGER
124		>
125		> Specify the reordering of the diagonal blocks of T.
126		> The block with row index IFST is moved to row ILST, by a
127		> sequence of transpositions between adjacent blocks.
128		> On exit, if IFST pointed on entry to the second row of a
129		> 2-by-2 block, it is changed to point to the first row; ILST
130		> always points to the first row of the block in its final
131		> position (which may differ from its input value by +1 or -1).
132		> 1 <= IFST <= N; 1 <= ILST <= N.
133		> \endverbatim
134		>
135		> \param[out] WORK
136		> \verbatim
137		> WORK is DOUBLE PRECISION array, dimension (N)
138		> \endverbatim
139		>
140		> \param[out] INFO
141		> \verbatim
142		> INFO is INTEGER
143		> = 0: successful exit
144		> < 0: if INFO = -i, the i-th argument had an illegal value
145		> = 1: two adjacent blocks were too close to swap (the problem
146		> is very ill-conditioned); T may have been partially
147		> reordered, and ILST points to the first row of the
148		> current position of the block being moved.
149		> \endverbatim
150
151		Authors:
152		========
153
154		> \author Univ. of Tennessee
155		> \author Univ. of California Berkeley
156		> \author Univ. of Colorado Denver
157		> \author NAG Ltd.
158
159		> \date November 2011
160
161		> \ingroup doubleOTHERcomputational
162
163		=====================================================================
164		Subroutine / int igraphdtrexc_(char compq, integer n, doublereal t, integer *
165		ldt, doublereal q, integer ldq, integer ifst, integer ilst,
166		doublereal work, integer info)
167	0	{
168		/* System generated locals */
169	0	integer q_dim1, q_offset, t_dim1, t_offset, i__1;
170
171		/* Local variables */
172	0	integer nbf, nbl, here;
173	0	extern logical igraphlsame_(char , char );
174	0	logical wantq;
175	0	extern /* Subroutine / int igraphdlaexc_(logical , integer , doublereal ,
176	0	integer , doublereal , integer , integer , integer *, integer
177	0	, doublereal , integer ), igraphxerbla_(char , integer *, ftnlen);
178	0	integer nbnext;
179
180
181		/* -- LAPACK computational routine (version 3.4.0) --
182		-- LAPACK is a software package provided by Univ. of Tennessee, --
183		-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
184		November 2011
185
186
187		=====================================================================
188
189
190		Decode and test the input arguments.
191
192		Parameter adjustments */
193	0	t_dim1 = *ldt;
194	0	t_offset = 1 + t_dim1;
195	0	t -= t_offset;
196	0	q_dim1 = *ldq;
197	0	q_offset = 1 + q_dim1;
198	0	q -= q_offset;
199	0	--work;
200
201		/* Function Body */
202	0	*info = 0;
203	0	wantq = igraphlsame_(compq, "V");
204	0	if (! wantq && ! igraphlsame_(compq, "N")) {
205	0	*info = -1;
206	0	} else if (*n < 0) {
207	0	*info = -2;
208	0	} else if (ldt < max(1,n)) {
209	0	*info = -4;
210	0	} else if (ldq < 1 \|\| wantq && ldq < max(1,*n)) {
211	0	*info = -6;
212	0	} else if (ifst < 1 \|\| ifst > *n) {
213	0	*info = -7;
214	0	} else if (ilst < 1 \|\| ilst > *n) {
215	0	*info = -8;
216	0	}
217	0	if (*info != 0) {
218	0	i__1 = -(*info);
219	0	igraphxerbla_("DTREXC", &i__1, (ftnlen)6);
220	0	return 0;
221	0	}
222
223		/* Quick return if possible */
224
225	0	if (*n <= 1) {
226	0	return 0;
227	0	}
228
229		/* Determine the first row of specified block
230		and find out it is 1 by 1 or 2 by 2. */
231
232	0	if (*ifst > 1) {
233	0	if (t[ifst + (ifst - 1) * t_dim1] != 0.) {
234	0	--(*ifst);
235	0	}
236	0	}
237	0	nbf = 1;
238	0	if (ifst < n) {
239	0	if (t[ifst + 1 + ifst * t_dim1] != 0.) {
240	0	nbf = 2;
241	0	}
242	0	}
243
244		/* Determine the first row of the final block
245		and find out it is 1 by 1 or 2 by 2. */
246
247	0	if (*ilst > 1) {
248	0	if (t[ilst + (ilst - 1) * t_dim1] != 0.) {
249	0	--(*ilst);
250	0	}
251	0	}
252	0	nbl = 1;
253	0	if (ilst < n) {
254	0	if (t[ilst + 1 + ilst * t_dim1] != 0.) {
255	0	nbl = 2;
256	0	}
257	0	}
258
259	0	if (ifst == ilst) {
260	0	return 0;
261	0	}
262
263	0	if (ifst < ilst) {
264
265		/* Update ILST */
266
267	0	if (nbf == 2 && nbl == 1) {
268	0	--(*ilst);
269	0	}
270	0	if (nbf == 1 && nbl == 2) {
271	0	++(*ilst);
272	0	}
273
274	0	here = *ifst;
275
276	0	L10:
277
278		/* Swap block with next one below */
279
280	0	if (nbf == 1 \|\| nbf == 2) {
281
282		/* Current block either 1 by 1 or 2 by 2 */
283
284	0	nbnext = 1;
285	0	if (here + nbf + 1 <= *n) {
286	0	if (t[here + nbf + 1 + (here + nbf) * t_dim1] != 0.) {
287	0	nbnext = 2;
288	0	}
289	0	}
290	0	igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &here, &
291	0	nbf, &nbnext, &work[1], info);
292	0	if (*info != 0) {
293	0	*ilst = here;
294	0	return 0;
295	0	}
296	0	here += nbnext;
297
298		/* Test if 2 by 2 block breaks into two 1 by 1 blocks */
299
300	0	if (nbf == 2) {
301	0	if (t[here + 1 + here * t_dim1] == 0.) {
302	0	nbf = 3;
303	0	}
304	0	}
305
306	0	} else {
307
308		/* Current block consists of two 1 by 1 blocks each of which
309		must be swapped individually */
310
311	0	nbnext = 1;
312	0	if (here + 3 <= *n) {
313	0	if (t[here + 3 + (here + 2) * t_dim1] != 0.) {
314	0	nbnext = 2;
315	0	}
316	0	}
317	0	i__1 = here + 1;
318	0	igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &
319	0	c__1, &nbnext, &work[1], info);
320	0	if (*info != 0) {
321	0	*ilst = here;
322	0	return 0;
323	0	}
324	0	if (nbnext == 1) {
325
326		/* Swap two 1 by 1 blocks, no problems possible */
327
328	0	igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
329	0	here, &c__1, &nbnext, &work[1], info);
330	0	++here;
331	0	} else {
332
333		/* Recompute NBNEXT in case 2 by 2 split */
334
335	0	if (t[here + 2 + (here + 1) * t_dim1] == 0.) {
336	0	nbnext = 1;
337	0	}
338	0	if (nbnext == 2) {
339
340		/* 2 by 2 Block did not split */
341
342	0	igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
343	0	here, &c__1, &nbnext, &work[1], info);
344	0	if (*info != 0) {
345	0	*ilst = here;
346	0	return 0;
347	0	}
348	0	here += 2;
349	0	} else {
350
351		/* 2 by 2 Block did split */
352
353	0	igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
354	0	here, &c__1, &c__1, &work[1], info);
355	0	i__1 = here + 1;
356	0	igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
357	0	i__1, &c__1, &c__1, &work[1], info);
358	0	here += 2;
359	0	}
360	0	}
361	0	}
362	0	if (here < *ilst) {
363	0	goto L10;
364	0	}
365
366	0	} else {
367
368	0	here = *ifst;
369	0	L20:
370
371		/* Swap block with next one above */
372
373	0	if (nbf == 1 \|\| nbf == 2) {
374
375		/* Current block either 1 by 1 or 2 by 2 */
376
377	0	nbnext = 1;
378	0	if (here >= 3) {
379	0	if (t[here - 1 + (here - 2) * t_dim1] != 0.) {
380	0	nbnext = 2;
381	0	}
382	0	}
383	0	i__1 = here - nbnext;
384	0	igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &
385	0	nbnext, &nbf, &work[1], info);
386	0	if (*info != 0) {
387	0	*ilst = here;
388	0	return 0;
389	0	}
390	0	here -= nbnext;
391
392		/* Test if 2 by 2 block breaks into two 1 by 1 blocks */
393
394	0	if (nbf == 2) {
395	0	if (t[here + 1 + here * t_dim1] == 0.) {
396	0	nbf = 3;
397	0	}
398	0	}
399
400	0	} else {
401
402		/* Current block consists of two 1 by 1 blocks each of which
403		must be swapped individually */
404
405	0	nbnext = 1;
406	0	if (here >= 3) {
407	0	if (t[here - 1 + (here - 2) * t_dim1] != 0.) {
408	0	nbnext = 2;
409	0	}
410	0	}
411	0	i__1 = here - nbnext;
412	0	igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &
413	0	nbnext, &c__1, &work[1], info);
414	0	if (*info != 0) {
415	0	*ilst = here;
416	0	return 0;
417	0	}
418	0	if (nbnext == 1) {
419
420		/* Swap two 1 by 1 blocks, no problems possible */
421
422	0	igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
423	0	here, &nbnext, &c__1, &work[1], info);
424	0	--here;
425	0	} else {
426
427		/* Recompute NBNEXT in case 2 by 2 split */
428
429	0	if (t[here + (here - 1) * t_dim1] == 0.) {
430	0	nbnext = 1;
431	0	}
432	0	if (nbnext == 2) {
433
434		/* 2 by 2 Block did not split */
435
436	0	i__1 = here - 1;
437	0	igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
438	0	i__1, &c__2, &c__1, &work[1], info);
439	0	if (*info != 0) {
440	0	*ilst = here;
441	0	return 0;
442	0	}
443	0	here += -2;
444	0	} else {
445
446		/* 2 by 2 Block did split */
447
448	0	igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
449	0	here, &c__1, &c__1, &work[1], info);
450	0	i__1 = here - 1;
451	0	igraphdlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
452	0	i__1, &c__1, &c__1, &work[1], info);
453	0	here += -2;
454	0	}
455	0	}
456	0	}
457	0	if (here > *ilst) {
458	0	goto L20;
459	0	}
460	0	}
461	0	*ilst = here;
462
463	0	return 0;
464
465		/* End of DTREXC */
466
467	0	} /* igraphdtrexc_ */
468