123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115 |
- /* eigen/gen.c
- *
- * Copyright (C) 2006, 2007 Patrick Alken
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 3 of the License, or (at
- * your option) any later version.
- *
- * This program is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this program; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
- */
- #include <stdlib.h>
- #include <math.h>
- #include "gsl__config.h"
- #include "gsl_eigen.h"
- #include "gsl_linalg.h"
- #include "gsl_math.h"
- #include "gsl_blas.h"
- #include "gsl_vector.h"
- #include "gsl_vector_complex.h"
- #include "gsl_matrix.h"
- /*
- * This module computes the eigenvalues of a real generalized
- * eigensystem A x = \lambda B x. Left and right Schur vectors
- * are optionally computed as well.
- *
- * Based on the algorithm from Moler and Stewart
- * [1] C. Moler, G. Stewart, "An Algorithm for Generalized Matrix
- * Eigenvalue Problems", SIAM J. Numer. Anal., Vol 10, No 2, 1973.
- *
- * This algorithm is also described in the book
- * [2] Golub & Van Loan, "Matrix Computations" (3rd ed), algorithm 7.7.3
- *
- * This file contains routines based on original code from LAPACK
- * which is distributed under the modified BSD license.
- */
- #define GEN_ESHIFT_COEFF (1.736)
- static void gen_schur_decomp(gsl_matrix *H, gsl_matrix *R,
- gsl_vector_complex *alpha, gsl_vector *beta,
- gsl_eigen_gen_workspace *w);
- static inline int gen_qzstep(gsl_matrix *H, gsl_matrix *R,
- gsl_eigen_gen_workspace *w);
- static inline void gen_qzstep_d(gsl_matrix *H, gsl_matrix *R,
- gsl_eigen_gen_workspace *w);
- static void gen_tri_split_top(gsl_matrix *H, gsl_matrix *R,
- gsl_eigen_gen_workspace *w);
- static inline void gen_tri_chase_zero(gsl_matrix *H, gsl_matrix *R,
- size_t q,
- gsl_eigen_gen_workspace *w);
- static inline void gen_tri_zero_H(gsl_matrix *H, gsl_matrix *R,
- gsl_eigen_gen_workspace *w);
- static inline size_t gen_search_small_elements(gsl_matrix *H,
- gsl_matrix *R,
- int *flag,
- gsl_eigen_gen_workspace *w);
- static int gen_schur_standardize1(gsl_matrix *A, gsl_matrix *B,
- double *alphar, double *beta,
- gsl_eigen_gen_workspace *w);
- static int gen_schur_standardize2(gsl_matrix *A, gsl_matrix *B,
- gsl_complex *alpha1,
- gsl_complex *alpha2,
- double *beta1, double *beta2,
- gsl_eigen_gen_workspace *w);
- static int gen_compute_eigenvals(gsl_matrix *A, gsl_matrix *B,
- gsl_complex *alpha1,
- gsl_complex *alpha2, double *beta1,
- double *beta2);
- static void gen_store_eigval1(const gsl_matrix *H, const double a,
- const double b, gsl_vector_complex *alpha,
- gsl_vector *beta,
- gsl_eigen_gen_workspace *w);
- static void gen_store_eigval2(const gsl_matrix *H,
- const gsl_complex *alpha1,
- const double beta1,
- const gsl_complex *alpha2,
- const double beta2,
- gsl_vector_complex *alpha,
- gsl_vector *beta,
- gsl_eigen_gen_workspace *w);
- static inline size_t gen_get_submatrix(const gsl_matrix *A,
- const gsl_matrix *B);
- /*FIX**/
- inline static double normF (gsl_matrix * A);
- inline static void create_givens (const double a, const double b, double *c, double *s);
- /*
- gsl_eigen_gen_alloc()
- Allocate a workspace for solving the generalized eigenvalue problem.
- The size of this workspace is O(n)
- Inputs: n - size of matrices
- Return: pointer to workspace
- */
- gsl_eigen_gen_workspace *
- gsl_eigen_gen_alloc(const size_t n)
- {
- gsl_eigen_gen_workspace *w;
- if (n == 0)
- {
- GSL_ERROR_NULL ("matrix dimension must be positive integer",
- GSL_EINVAL);
- }
- w = (gsl_eigen_gen_workspace *) calloc (1, sizeof (gsl_eigen_gen_workspace));
- if (w == 0)
- {
- GSL_ERROR_NULL ("failed to allocate space for workspace", GSL_ENOMEM);
- }
- w->size = n;
- w->max_iterations = 30 * n;
- w->n_evals = 0;
- w->n_iter = 0;
- w->needtop = 0;
- w->atol = 0.0;
- w->btol = 0.0;
- w->ascale = 0.0;
- w->bscale = 0.0;
- w->eshift = 0.0;
- w->H = NULL;
- w->R = NULL;
- w->compute_s = 0;
- w->compute_t = 0;
- w->Q = NULL;
- w->Z = NULL;
- w->work = gsl_vector_alloc(n);
- if (w->work == 0)
- {
- gsl_eigen_gen_free(w);
- GSL_ERROR_NULL ("failed to allocate space for additional workspace", GSL_ENOMEM);
- }
- return (w);
- } /* gsl_eigen_gen_alloc() */
- /*
- gsl_eigen_gen_free()
- Free workspace w
- */
- void
- gsl_eigen_gen_free (gsl_eigen_gen_workspace * w)
- {
- if (w->work)
- gsl_vector_free(w->work);
- free(w);
- } /* gsl_eigen_gen_free() */
- /*
- gsl_eigen_gen_params()
- Set parameters which define how we solve the eigenvalue problem
- Inputs: compute_s - 1 if we want to compute S, 0 if not
- compute_t - 1 if we want to compute T, 0 if not
- balance - 1 if we want to balance matrices, 0 if not
- w - gen workspace
- Return: none
- */
- void
- gsl_eigen_gen_params (const int compute_s, const int compute_t,
- const int balance, gsl_eigen_gen_workspace *w)
- {
- w->compute_s = compute_s;
- w->compute_t = compute_t;
- } /* gsl_eigen_gen_params() */
- /*
- gsl_eigen_gen()
- Solve the generalized eigenvalue problem
- A x = \lambda B x
- for the eigenvalues \lambda.
- Inputs: A - general real matrix
- B - general real matrix
- alpha - where to store eigenvalue numerators
- beta - where to store eigenvalue denominators
- w - workspace
- Return: success or error
- */
- int
- gsl_eigen_gen (gsl_matrix * A, gsl_matrix * B, gsl_vector_complex * alpha,
- gsl_vector * beta, gsl_eigen_gen_workspace * w)
- {
- const size_t N = A->size1;
- /* check matrix and vector sizes */
- if (N != A->size2)
- {
- GSL_ERROR ("matrix must be square to compute eigenvalues", GSL_ENOTSQR);
- }
- else if ((N != B->size1) || (N != B->size2))
- {
- GSL_ERROR ("B matrix dimensions must match A", GSL_EBADLEN);
- }
- else if (alpha->size != N || beta->size != N)
- {
- GSL_ERROR ("eigenvalue vector must match matrix size", GSL_EBADLEN);
- }
- else if (w->size != N)
- {
- GSL_ERROR ("matrix size does not match workspace", GSL_EBADLEN);
- }
- else
- {
- double anorm, bnorm;
- /* compute the Hessenberg-Triangular reduction of (A, B) */
- gsl_linalg_hesstri_decomp(A, B, w->Q, w->Z, w->work);
- /* save pointers to original matrices */
- w->H = A;
- w->R = B;
- w->n_evals = 0;
- w->n_iter = 0;
- w->eshift = 0.0;
- /* determine if we need to compute top indices in QZ step */
- w->needtop = w->Q != 0 || w->Z != 0 || w->compute_t || w->compute_s;
- /* compute matrix norms */
- anorm = normF(A);
- bnorm = normF(B);
- /* compute tolerances and scaling factors */
- w->atol = GSL_MAX(GSL_DBL_MIN, GSL_DBL_EPSILON * anorm);
- w->btol = GSL_MAX(GSL_DBL_MIN, GSL_DBL_EPSILON * bnorm);
- w->ascale = 1.0 / GSL_MAX(GSL_DBL_MIN, anorm);
- w->bscale = 1.0 / GSL_MAX(GSL_DBL_MIN, bnorm);
- /* compute the generalized Schur decomposition and eigenvalues */
- gen_schur_decomp(A, B, alpha, beta, w);
- if (w->n_evals != N)
- return GSL_EMAXITER;
- return GSL_SUCCESS;
- }
- } /* gsl_eigen_gen() */
- /*
- gsl_eigen_gen_QZ()
- Solve the generalized eigenvalue problem
- A x = \lambda B x
- for the eigenvalues \lambda. Optionally compute left and/or right
- Schur vectors Q and Z which satisfy:
- A = Q S Z^t
- B = Q T Z^t
- where (S, T) is the generalized Schur form of (A, B)
- Inputs: A - general real matrix
- B - general real matrix
- alpha - where to store eigenvalue numerators
- beta - where to store eigenvalue denominators
- Q - if non-null, where to store left Schur vectors
- Z - if non-null, where to store right Schur vectors
- w - workspace
- Return: success or error
- */
- int
- gsl_eigen_gen_QZ (gsl_matrix * A, gsl_matrix * B,
- gsl_vector_complex * alpha, gsl_vector * beta,
- gsl_matrix * Q, gsl_matrix * Z,
- gsl_eigen_gen_workspace * w)
- {
- if (Q && (A->size1 != Q->size1 || A->size1 != Q->size2))
- {
- GSL_ERROR("Q matrix has wrong dimensions", GSL_EBADLEN);
- }
- else if (Z && (A->size1 != Z->size1 || A->size1 != Z->size2))
- {
- GSL_ERROR("Z matrix has wrong dimensions", GSL_EBADLEN);
- }
- else
- {
- int s;
- w->Q = Q;
- w->Z = Z;
- s = gsl_eigen_gen(A, B, alpha, beta, w);
- w->Q = NULL;
- w->Z = NULL;
- return s;
- }
- } /* gsl_eigen_gen_QZ() */
- /********************************************
- * INTERNAL ROUTINES *
- ********************************************/
- /*
- gen_schur_decomp()
- Compute the generalized Schur decomposition of the matrix pencil
- (H, R) which is in Hessenberg-Triangular form
- Inputs: H - upper hessenberg matrix
- R - upper triangular matrix
- alpha - (output) where to store eigenvalue numerators
- beta - (output) where to store eigenvalue denominators
- w - workspace
- Return: none
- Notes: 1) w->n_evals is updated to keep track of how many eigenvalues
- are found
- */
- static void
- gen_schur_decomp(gsl_matrix *H, gsl_matrix *R, gsl_vector_complex *alpha,
- gsl_vector *beta, gsl_eigen_gen_workspace *w)
- {
- size_t N;
- gsl_matrix_view h, r;
- gsl_matrix_view vh, vr;
- size_t q; /* index of small subdiagonal element */
- gsl_complex z1, z2; /* complex values */
- double a, b;
- int s;
- int flag;
- N = H->size1;
- h = gsl_matrix_submatrix(H, 0, 0, N, N);
- r = gsl_matrix_submatrix(R, 0, 0, N, N);
- while ((N > 1) && (w->n_iter)++ < w->max_iterations)
- {
- q = gen_search_small_elements(&h.matrix, &r.matrix, &flag, w);
- if (flag == 0)
- {
- /* no small elements found - do a QZ sweep */
- s = gen_qzstep(&h.matrix, &r.matrix, w);
- if (s == GSL_CONTINUE)
- {
- /*
- * (h, r) is a 2-by-2 block with complex eigenvalues -
- * standardize and read off eigenvalues
- */
- s = gen_schur_standardize2(&h.matrix,
- &r.matrix,
- &z1,
- &z2,
- &a,
- &b,
- w);
- if (s != GSL_SUCCESS)
- {
- /*
- * if we get here, then the standardization process
- * perturbed the eigenvalues onto the real line -
- * continue QZ iteration to break them into 1-by-1
- * blocks
- */
- continue;
- }
- gen_store_eigval2(&h.matrix, &z1, a, &z2, b, alpha, beta, w);
- N = 0;
- } /* if (s) */
- continue;
- } /* if (flag == 0) */
- else if (flag == 2)
- {
- if (q == 0)
- {
- /*
- * the leading element of R is zero, split off a block
- * at the top
- */
- gen_tri_split_top(&h.matrix, &r.matrix, w);
- }
- else
- {
- /*
- * we found a small element on the diagonal of R - chase the
- * zero to the bottom of the active block and then zero
- * H(n, n - 1) to split off a 1-by-1 block
- */
- if (q != N - 1)
- gen_tri_chase_zero(&h.matrix, &r.matrix, q, w);
- /* now zero H(n, n - 1) */
- gen_tri_zero_H(&h.matrix, &r.matrix, w);
- }
- /* continue so the next iteration detects the zero in H */
- continue;
- }
- /*
- * a small subdiagonal element of H was found - one or two
- * eigenvalues have converged or the matrix has split into
- * two smaller matrices
- */
- if (q == (N - 1))
- {
- /*
- * the last subdiagonal element of the hessenberg matrix is 0 -
- * H_{NN} / R_{NN} is a real eigenvalue - standardize so
- * R_{NN} > 0
- */
- vh = gsl_matrix_submatrix(&h.matrix, q, q, 1, 1);
- vr = gsl_matrix_submatrix(&r.matrix, q, q, 1, 1);
- gen_schur_standardize1(&vh.matrix, &vr.matrix, &a, &b, w);
- gen_store_eigval1(&vh.matrix, a, b, alpha, beta, w);
- --N;
- h = gsl_matrix_submatrix(&h.matrix, 0, 0, N, N);
- r = gsl_matrix_submatrix(&r.matrix, 0, 0, N, N);
- }
- else if (q == (N - 2))
- {
- /* bottom right 2-by-2 block may have converged */
- vh = gsl_matrix_submatrix(&h.matrix, q, q, 2, 2);
- vr = gsl_matrix_submatrix(&r.matrix, q, q, 2, 2);
- s = gen_schur_standardize2(&vh.matrix,
- &vr.matrix,
- &z1,
- &z2,
- &a,
- &b,
- w);
- if (s != GSL_SUCCESS)
- {
- /*
- * this 2-by-2 block contains real eigenvalues that
- * have not yet separated into 1-by-1 blocks -
- * recursively call gen_schur_decomp() to finish off
- * this block
- */
- gen_schur_decomp(&vh.matrix, &vr.matrix, alpha, beta, w);
- }
- else
- {
- /* we got 2 complex eigenvalues */
- gen_store_eigval2(&vh.matrix, &z1, a, &z2, b, alpha, beta, w);
- }
- N -= 2;
- h = gsl_matrix_submatrix(&h.matrix, 0, 0, N, N);
- r = gsl_matrix_submatrix(&r.matrix, 0, 0, N, N);
- }
- else if (q == 1)
- {
- /* H_{11} / R_{11} is an eigenvalue */
- vh = gsl_matrix_submatrix(&h.matrix, 0, 0, 1, 1);
- vr = gsl_matrix_submatrix(&r.matrix, 0, 0, 1, 1);
- gen_schur_standardize1(&vh.matrix, &vr.matrix, &a, &b, w);
- gen_store_eigval1(&vh.matrix, a, b, alpha, beta, w);
- --N;
- h = gsl_matrix_submatrix(&h.matrix, 1, 1, N, N);
- r = gsl_matrix_submatrix(&r.matrix, 1, 1, N, N);
- }
- else if (q == 2)
- {
- /* upper left 2-by-2 block may have converged */
- vh = gsl_matrix_submatrix(&h.matrix, 0, 0, 2, 2);
- vr = gsl_matrix_submatrix(&r.matrix, 0, 0, 2, 2);
- s = gen_schur_standardize2(&vh.matrix,
- &vr.matrix,
- &z1,
- &z2,
- &a,
- &b,
- w);
- if (s != GSL_SUCCESS)
- {
- /*
- * this 2-by-2 block contains real eigenvalues that
- * have not yet separated into 1-by-1 blocks -
- * recursively call gen_schur_decomp() to finish off
- * this block
- */
- gen_schur_decomp(&vh.matrix, &vr.matrix, alpha, beta, w);
- }
- else
- {
- /* we got 2 complex eigenvalues */
- gen_store_eigval2(&vh.matrix, &z1, a, &z2, b, alpha, beta, w);
- }
- N -= 2;
- h = gsl_matrix_submatrix(&h.matrix, 2, 2, N, N);
- r = gsl_matrix_submatrix(&r.matrix, 2, 2, N, N);
- }
- else
- {
- /*
- * There is a zero element on the subdiagonal somewhere
- * in the middle of the matrix - we can now operate
- * separately on the two submatrices split by this
- * element. q is the row index of the zero element.
- */
- /* operate on lower right (N - q)-by-(N - q) block first */
- vh = gsl_matrix_submatrix(&h.matrix, q, q, N - q, N - q);
- vr = gsl_matrix_submatrix(&r.matrix, q, q, N - q, N - q);
- gen_schur_decomp(&vh.matrix, &vr.matrix, alpha, beta, w);
- /* operate on upper left q-by-q block */
- vh = gsl_matrix_submatrix(&h.matrix, 0, 0, q, q);
- vr = gsl_matrix_submatrix(&r.matrix, 0, 0, q, q);
- gen_schur_decomp(&vh.matrix, &vr.matrix, alpha, beta, w);
- N = 0;
- }
- } /* while ((N > 1) && (w->n_iter)++ < w->max_iterations) */
- /* handle special case of N = 1 */
- if (N == 1)
- {
- gen_schur_standardize1(&h.matrix, &r.matrix, &a, &b, w);
- gen_store_eigval1(&h.matrix, a, b, alpha, beta, w);
- }
- } /* gen_schur_decomp() */
- /*
- gen_qzstep()
- This routine determines what type of QZ step to perform on
- the generalized matrix pair (H, R). If the pair is 3-by-3 or bigger,
- we look at the bottom right 2-by-2 block. If this block has complex
- eigenvalues, we perform a Francis double shift QZ sweep. If it
- has real eigenvalues, we perform an implicit single shift QZ sweep.
- If the pair is 2-by-2 with real eigenvalues, we perform a single
- shift sweep. If it has complex eigenvalues, we return GSL_CONTINUE
- to notify the calling function that a 2-by-2 block with complex
- eigenvalues has converged, so that it may then call
- gen_schur_standardize2(). In the real eigenvalue case, we want to
- continue doing QZ sweeps to break it up into two 1-by-1 blocks.
- See LAPACK routine DHGEQZ and [1] for more information.
- Inputs: H - upper Hessenberg matrix (at least 2-by-2)
- R - upper triangular matrix (at least 2-by-2)
- w - workspace
- Return: GSL_SUCCESS on normal completion
- GSL_CONTINUE if we detect a 2-by-2 block with complex eigenvalues
- */
- static inline int
- gen_qzstep(gsl_matrix *H, gsl_matrix *R, gsl_eigen_gen_workspace *w)
- {
- const size_t N = H->size1;
- gsl_matrix_view vh, vr; /* views of bottom right 2-by-2 block */
- double wr1, wr2, wi;
- double scale1, scale2, scale;
- double cs, sn; /* givens rotation */
- double temp, /* temporary variables */
- temp2;
- size_t j; /* looping */
- gsl_vector_view xv, yv; /* temporary views */
- size_t top;
- size_t rows;
- if (w->n_iter % 10 == 0)
- {
- /*
- * Exceptional shift - we have gone 10 iterations without finding
- * a new eigenvalue, do a single shift sweep with an
- * exceptional shift
- */
- if ((GSL_DBL_MIN * w->max_iterations) *
- fabs(gsl_matrix_get(H, N - 2, N - 1)) <
- fabs(gsl_matrix_get(R, N - 2, N - 2)))
- {
- w->eshift += gsl_matrix_get(H, N - 2, N - 1) /
- gsl_matrix_get(R, N - 2, N - 2);
- }
- else
- w->eshift += 1.0 / (GSL_DBL_MIN * w->max_iterations);
- if ((w->eshift < GSL_DBL_EPSILON) &&
- (GSL_DBL_MIN * w->max_iterations) *
- fabs(gsl_matrix_get(H, N - 1, N - 2)) <
- fabs(gsl_matrix_get(R, N - 2, N - 2)))
- {
- w->eshift = GEN_ESHIFT_COEFF *
- (w->ascale * gsl_matrix_get(H, N - 1, N - 2)) /
- (w->bscale * gsl_matrix_get(R, N - 2, N - 2));
- }
- scale1 = 1.0;
- wr1 = w->eshift;
- }
- else
- {
- /*
- * Compute generalized eigenvalues of bottom right 2-by-2 block
- * to be used as shifts - wr1 is the Wilkinson shift
- */
- vh = gsl_matrix_submatrix(H, N - 2, N - 2, 2, 2);
- vr = gsl_matrix_submatrix(R, N - 2, N - 2, 2, 2);
- gsl_schur_gen_eigvals(&vh.matrix,
- &vr.matrix,
- &wr1,
- &wr2,
- &wi,
- &scale1,
- &scale2);
- if (wi != 0.0)
- {
- /* complex eigenvalues */
- if (N == 2)
- {
- /*
- * its a 2-by-2 block with complex eigenvalues - notify
- * the calling function to deflate
- */
- return (GSL_CONTINUE);
- }
- else
- {
- /* do a francis double shift sweep */
- gen_qzstep_d(H, R, w);
- }
- return GSL_SUCCESS;
- }
- }
- /* real eigenvalues - perform single shift QZ step */
- temp = GSL_MIN(w->ascale, 1.0) * (0.5 / GSL_DBL_MIN);
- if (scale1 > temp)
- scale = temp / scale1;
- else
- scale = 1.0;
- temp = GSL_MIN(w->bscale, 1.0) * (0.5 / GSL_DBL_MIN);
- if (fabs(wr1) > temp)
- scale = GSL_MIN(scale, temp / fabs(wr1));
- scale1 *= scale;
- wr1 *= scale;
- if (w->needtop)
- {
- /* get absolute index of this matrix relative to original matrix */
- top = gen_get_submatrix(w->H, H);
- }
- temp = scale1*gsl_matrix_get(H, 0, 0) - wr1*gsl_matrix_get(R, 0, 0);
- temp2 = scale1*gsl_matrix_get(H, 1, 0);
- create_givens(temp, temp2, &cs, &sn);
- sn = -sn;
- for (j = 0; j < N - 1; ++j)
- {
- if (j > 0)
- {
- temp = gsl_matrix_get(H, j, j - 1);
- temp2 = gsl_matrix_get(H, j + 1, j - 1);
- create_givens(temp, temp2, &cs, &sn);
- sn = -sn;
- /* apply to column (j - 1) */
- temp = cs * gsl_matrix_get(H, j, j - 1) +
- sn * gsl_matrix_get(H, j + 1, j - 1);
- gsl_matrix_set(H, j, j - 1, temp);
- gsl_matrix_set(H, j + 1, j - 1, 0.0);
- }
- /* apply G to H(j:j+1,:) and T(j:j+1,:) */
- if (w->compute_s)
- {
- xv = gsl_matrix_subrow(w->H, top + j, top + j, w->size - top - j);
- yv = gsl_matrix_subrow(w->H, top + j + 1, top + j, w->size - top - j);
- }
- else
- {
- xv = gsl_matrix_subrow(H, j, j, N - j);
- yv = gsl_matrix_subrow(H, j + 1, j, N - j);
- }
- gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
- if (w->compute_t)
- {
- xv = gsl_matrix_subrow(w->R, top + j, top + j, w->size - top - j);
- yv = gsl_matrix_subrow(w->R, top + j + 1, top + j, w->size - top - j);
- }
- else
- {
- xv = gsl_matrix_subrow(R, j, j, N - j);
- yv = gsl_matrix_subrow(R, j + 1, j, N - j);
- }
- gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
- if (w->Q)
- {
- /* accumulate Q: Q -> QG */
- xv = gsl_matrix_column(w->Q, top + j);
- yv = gsl_matrix_column(w->Q, top + j + 1);
- gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
- }
- temp = gsl_matrix_get(R, j + 1, j + 1);
- temp2 = gsl_matrix_get(R, j + 1, j);
- create_givens(temp, temp2, &cs, &sn);
- rows = GSL_MIN(j + 3, N);
- if (w->compute_s)
- {
- xv = gsl_matrix_subcolumn(w->H, top + j, 0, top + rows);
- yv = gsl_matrix_subcolumn(w->H, top + j + 1, 0, top + rows);
- }
- else
- {
- xv = gsl_matrix_subcolumn(H, j, 0, rows);
- yv = gsl_matrix_subcolumn(H, j + 1, 0, rows);
- }
- gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
- rows = GSL_MIN(j + 2, N);
- if (w->compute_t)
- {
- xv = gsl_matrix_subcolumn(w->R, top + j, 0, top + rows);
- yv = gsl_matrix_subcolumn(w->R, top + j + 1, 0, top + rows);
- }
- else
- {
- xv = gsl_matrix_subcolumn(R, j, 0, rows);
- yv = gsl_matrix_subcolumn(R, j + 1, 0, rows);
- }
- gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
- if (w->Z)
- {
- /* accumulate Z: Z -> ZG */
- xv = gsl_matrix_column(w->Z, top + j);
- yv = gsl_matrix_column(w->Z, top + j + 1);
- gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
- }
- } /* for (j = 0; j < N - 1; ++j) */
- return GSL_SUCCESS;
- } /* gen_qzstep() */
- /*
- gen_qzstep_d()
- Perform an implicit double shift QZ step.
- See Golub & Van Loan, "Matrix Computations" (3rd ed), algorithm 7.7.2
- Inputs: H - upper Hessenberg matrix (at least 3-by-3)
- R - upper triangular matrix (at least 3-by-3)
- w - workspace
- */
- static inline void
- gen_qzstep_d(gsl_matrix *H, gsl_matrix *R, gsl_eigen_gen_workspace *w)
- {
- const size_t N = H->size1;
- size_t j; /* looping */
- double dat[3]; /* householder vector */
- double tau; /* householder coefficient */
- gsl_vector_view v2, v3; /* views into 'dat' */
- gsl_matrix_view m; /* temporary view */
- double tmp;
- size_t q, r;
- size_t top; /* location of H in original matrix */
- double scale;
- double AB11, /* various matrix element ratios */
- AB22,
- ABNN,
- ABMM,
- AMNBNN,
- ANMBMM,
- A21B11,
- A12B22,
- A32B22,
- B12B22,
- BMNBNN;
- v2 = gsl_vector_view_array(dat, 2);
- v3 = gsl_vector_view_array(dat, 3);
- if (w->needtop)
- {
- /* get absolute index of this matrix relative to original matrix */
- top = gen_get_submatrix(w->H, H);
- }
- /*
- * Similar to the QR method, we take the shifts to be the two
- * zeros of the problem
- *
- * det[H(n-1:n,n-1:n) - s*R(n-1:n,n-1:n)] = 0
- *
- * The initial householder vector elements are then given by
- * Eq. 4.1 of [1], which are designed to reduce errors when
- * off diagonal elements are small.
- */
- ABMM = (w->ascale * gsl_matrix_get(H, N - 2, N - 2)) /
- (w->bscale * gsl_matrix_get(R, N - 2, N - 2));
- ABNN = (w->ascale * gsl_matrix_get(H, N - 1, N - 1)) /
- (w->bscale * gsl_matrix_get(R, N - 1, N - 1));
- AB11 = (w->ascale * gsl_matrix_get(H, 0, 0)) /
- (w->bscale * gsl_matrix_get(R, 0, 0));
- AB22 = (w->ascale * gsl_matrix_get(H, 1, 1)) /
- (w->bscale * gsl_matrix_get(R, 1, 1));
- AMNBNN = (w->ascale * gsl_matrix_get(H, N - 2, N - 1)) /
- (w->bscale * gsl_matrix_get(R, N - 1, N - 1));
- ANMBMM = (w->ascale * gsl_matrix_get(H, N - 1, N - 2)) /
- (w->bscale * gsl_matrix_get(R, N - 2, N - 2));
- BMNBNN = gsl_matrix_get(R, N - 2, N - 1) /
- gsl_matrix_get(R, N - 1, N - 1);
- A21B11 = (w->ascale * gsl_matrix_get(H, 1, 0)) /
- (w->bscale * gsl_matrix_get(R, 0, 0));
- A12B22 = (w->ascale * gsl_matrix_get(H, 0, 1)) /
- (w->bscale * gsl_matrix_get(R, 1, 1));
- A32B22 = (w->ascale * gsl_matrix_get(H, 2, 1)) /
- (w->bscale * gsl_matrix_get(R, 1, 1));
- B12B22 = gsl_matrix_get(R, 0, 1) / gsl_matrix_get(R, 1, 1);
- /*
- * These are the Eqs (4.1) of [1], just multiplied by the factor
- * (A_{21} / B_{11})
- */
- dat[0] = (ABMM - AB11) * (ABNN - AB11) - (AMNBNN * ANMBMM) +
- (ANMBMM * BMNBNN * AB11) + (A12B22 - (AB11 * B12B22)) * A21B11;
- dat[1] = ((AB22 - AB11) - (A21B11 * B12B22) - (ABMM - AB11) -
- (ABNN - AB11) + (ANMBMM * BMNBNN)) * A21B11;
- dat[2] = A32B22 * A21B11;
- scale = fabs(dat[0]) + fabs(dat[1]) + fabs(dat[2]);
- if (scale != 0.0)
- {
- dat[0] /= scale;
- dat[1] /= scale;
- dat[2] /= scale;
- }
- for (j = 0; j < N - 2; ++j)
- {
- r = GSL_MIN(j + 4, N);
- /*
- * Find householder Q so that
- *
- * Q [x y z]^t = [ * 0 0 ]^t
- */
- tau = gsl_linalg_householder_transform(&v3.vector);
- if (tau != 0.0)
- {
- /*
- * q is the initial column to start applying the householder
- * transformation. The GSL_MAX() simply ensures we don't
- * try to apply it to column (-1), since we are zeroing out
- * column (j - 1) except for the first iteration which
- * introduces the bulge.
- */
- q = (size_t) GSL_MAX(0, (int)j - 1);
- /* H -> QH, R -> QR */
- if (w->compute_s)
- {
- /*
- * We are computing the Schur form S, so we need to
- * transform the whole matrix H
- */
- m = gsl_matrix_submatrix(w->H,
- top + j,
- top + q,
- 3,
- w->size - top - q);
- gsl_linalg_householder_hm(tau, &v3.vector, &m.matrix);
- }
- else
- {
- /* just transform the active block */
- m = gsl_matrix_submatrix(H, j, q, 3, N - q);
- gsl_linalg_householder_hm(tau, &v3.vector, &m.matrix);
- }
- if (w->compute_t)
- {
- /*
- * We are computing the Schur form T, so we need to
- * transform the whole matrix R
- */
- m = gsl_matrix_submatrix(w->R,
- top + j,
- top + j,
- 3,
- w->size - top - j);
- gsl_linalg_householder_hm(tau, &v3.vector, &m.matrix);
- }
- else
- {
- /* just transform the active block */
- m = gsl_matrix_submatrix(R, j, j, 3, N - j);
- gsl_linalg_householder_hm(tau, &v3.vector, &m.matrix);
- }
- if (w->Q)
- {
- /* accumulate the transformation into Q */
- m = gsl_matrix_submatrix(w->Q, 0, top + j, w->size, 3);
- gsl_linalg_householder_mh(tau, &v3.vector, &m.matrix);
- }
- } /* if (tau != 0.0) */
- /*
- * Find householder Z so that
- *
- * [ r_{j+2,j} r_{j+2, j+1}, r_{j+2, j+2} ] Z = [ 0 0 * ]
- *
- * This isn't exactly what gsl_linalg_householder_transform
- * does, so we need to rotate the input vector so it preserves
- * the last element, and then rotate it back afterwards.
- *
- * So instead of transforming [x y z], we transform [z x y],
- * and the resulting HH vector [1 v2 v3] -> [v2 v3 1] but
- * then needs to be scaled to have the first element = 1, so
- * it becomes [1 v3/v2 1/v2] (tau must also be scaled accordingly).
- */
- dat[0] = gsl_matrix_get(R, j + 2, j + 2);
- dat[1] = gsl_matrix_get(R, j + 2, j);
- dat[2] = gsl_matrix_get(R, j + 2, j + 1);
- scale = fabs(dat[0]) + fabs(dat[1]) + fabs(dat[2]);
- if (scale != 0.0)
- {
- dat[0] /= scale;
- dat[1] /= scale;
- dat[2] /= scale;
- }
- tau = gsl_linalg_householder_transform(&v3.vector);
- if (tau != 0.0)
- {
- /* rotate back */
- tmp = gsl_vector_get(&v3.vector, 1);
- gsl_vector_set(&v3.vector, 1, gsl_vector_get(&v3.vector, 2)/tmp);
- gsl_vector_set(&v3.vector, 2, 1.0 / tmp);
- tau *= tmp * tmp;
- /* H -> HZ, R -> RZ */
- if (w->compute_s)
- {
- m = gsl_matrix_submatrix(w->H, 0, top + j, top + r, 3);
- gsl_linalg_householder_mh(tau, &v3.vector, &m.matrix);
- }
- else
- {
- m = gsl_matrix_submatrix(H, 0, j, r, 3);
- gsl_linalg_householder_mh(tau, &v3.vector, &m.matrix);
- }
- if (w->compute_t)
- {
- m = gsl_matrix_submatrix(w->R, 0, top + j, top + j + 3, 3);
- gsl_linalg_householder_mh(tau, &v3.vector, &m.matrix);
- }
- else
- {
- m = gsl_matrix_submatrix(R, 0, j, j + 3, 3);
- gsl_linalg_householder_mh(tau, &v3.vector, &m.matrix);
- }
- if (w->Z)
- {
- /* accumulate transformation into Z */
- m = gsl_matrix_submatrix(w->Z, 0, top + j, w->size, 3);
- gsl_linalg_householder_mh(tau, &v3.vector, &m.matrix);
- }
- } /* if (tau != 0.0) */
- /*
- * Find householder Z so that
- *
- * [ r_{j+1,j} r_{j+1, j+1} ] Z = [ 0 * ]
- */
- dat[0] = gsl_matrix_get(R, j + 1, j + 1);
- dat[1] = gsl_matrix_get(R, j + 1, j);
- scale = fabs(dat[0]) + fabs(dat[1]);
- if (scale != 0.0)
- {
- dat[0] /= scale;
- dat[1] /= scale;
- }
- tau = gsl_linalg_householder_transform(&v2.vector);
- if (tau != 0.0)
- {
- /* rotate back */
- tmp = gsl_vector_get(&v2.vector, 1);
- gsl_vector_set(&v2.vector, 1, 1.0 / tmp);
- tau *= tmp * tmp;
- /* H -> HZ, R -> RZ */
- if (w->compute_s)
- {
- m = gsl_matrix_submatrix(w->H, 0, top + j, top + r, 2);
- gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
- }
- else
- {
- m = gsl_matrix_submatrix(H, 0, j, r, 2);
- gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
- }
- if (w->compute_t)
- {
- m = gsl_matrix_submatrix(w->R, 0, top + j, top + j + 3, 2);
- gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
- }
- else
- {
- m = gsl_matrix_submatrix(R, 0, j, j + 3, 2);
- gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
- }
- if (w->Z)
- {
- /* accumulate transformation into Z */
- m = gsl_matrix_submatrix(w->Z, 0, top + j, w->size, 2);
- gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
- }
- } /* if (tau != 0.0) */
- dat[0] = gsl_matrix_get(H, j + 1, j);
- dat[1] = gsl_matrix_get(H, j + 2, j);
- if (j < N - 3)
- dat[2] = gsl_matrix_get(H, j + 3, j);
- scale = fabs(dat[0]) + fabs(dat[1]) + fabs(dat[2]);
- if (scale != 0.0)
- {
- dat[0] /= scale;
- dat[1] /= scale;
- dat[2] /= scale;
- }
- } /* for (j = 0; j < N - 2; ++j) */
- /*
- * Find Householder Q so that
- *
- * Q [ x y ]^t = [ * 0 ]^t
- */
- scale = fabs(dat[0]) + fabs(dat[1]);
- if (scale != 0.0)
- {
- dat[0] /= scale;
- dat[1] /= scale;
- }
- tau = gsl_linalg_householder_transform(&v2.vector);
-
- if (w->compute_s)
- {
- m = gsl_matrix_submatrix(w->H,
- top + N - 2,
- top + N - 3,
- 2,
- w->size - top - N + 3);
- gsl_linalg_householder_hm(tau, &v2.vector, &m.matrix);
- }
- else
- {
- m = gsl_matrix_submatrix(H, N - 2, N - 3, 2, 3);
- gsl_linalg_householder_hm(tau, &v2.vector, &m.matrix);
- }
- if (w->compute_t)
- {
- m = gsl_matrix_submatrix(w->R,
- top + N - 2,
- top + N - 2,
- 2,
- w->size - top - N + 2);
- gsl_linalg_householder_hm(tau, &v2.vector, &m.matrix);
- }
- else
- {
- m = gsl_matrix_submatrix(R, N - 2, N - 2, 2, 2);
- gsl_linalg_householder_hm(tau, &v2.vector, &m.matrix);
- }
- if (w->Q)
- {
- /* accumulate the transformation into Q */
- m = gsl_matrix_submatrix(w->Q, 0, top + N - 2, w->size, 2);
- gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
- }
- /*
- * Find Householder Z so that
- *
- * [ b_{n,n-1} b_{nn} ] Z = [ 0 * ]
- */
- dat[0] = gsl_matrix_get(R, N - 1, N - 1);
- dat[1] = gsl_matrix_get(R, N - 1, N - 2);
- scale = fabs(dat[0]) + fabs(dat[1]);
- if (scale != 0.0)
- {
- dat[0] /= scale;
- dat[1] /= scale;
- }
- tau = gsl_linalg_householder_transform(&v2.vector);
- /* rotate back */
- tmp = gsl_vector_get(&v2.vector, 1);
- gsl_vector_set(&v2.vector, 1, 1.0 / tmp);
- tau *= tmp * tmp;
- if (w->compute_s)
- {
- m = gsl_matrix_submatrix(w->H, 0, top + N - 2, top + N, 2);
- gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
- }
- else
- {
- m = gsl_matrix_submatrix(H, 0, N - 2, N, 2);
- gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
- }
- if (w->compute_t)
- {
- m = gsl_matrix_submatrix(w->R, 0, top + N - 2, top + N, 2);
- gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
- }
- else
- {
- m = gsl_matrix_submatrix(R, 0, N - 2, N, 2);
- gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
- }
- if (w->Z)
- {
- /* accumulate the transformation into Z */
- m = gsl_matrix_submatrix(w->Z, 0, top + N - 2, w->size, 2);
- gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
- }
- } /* gen_qzstep_d() */
- /*
- gen_tri_split_top()
- This routine is called when the leading element on the diagonal of R
- has become negligible. Split off a 1-by-1 block at the top.
- Inputs: H - upper hessenberg matrix
- R - upper triangular matrix
- w - workspace
- */
- static void
- gen_tri_split_top(gsl_matrix *H, gsl_matrix *R, gsl_eigen_gen_workspace *w)
- {
- const size_t N = H->size1;
- size_t j, top;
- double cs, sn;
- gsl_vector_view xv, yv;
- if (w->needtop)
- top = gen_get_submatrix(w->H, H);
- j = 0;
- create_givens(gsl_matrix_get(H, j, j),
- gsl_matrix_get(H, j + 1, j),
- &cs,
- &sn);
- sn = -sn;
- if (w->compute_s)
- {
- xv = gsl_matrix_subrow(w->H, top + j, top, w->size - top);
- yv = gsl_matrix_subrow(w->H, top + j + 1, top, w->size - top);
- }
- else
- {
- xv = gsl_matrix_row(H, j);
- yv = gsl_matrix_row(H, j + 1);
- }
- gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
- gsl_matrix_set(H, j + 1, j, 0.0);
- if (w->compute_t)
- {
- xv = gsl_matrix_subrow(w->R, top + j, top + 1, w->size - top - 1);
- yv = gsl_matrix_subrow(w->R, top + j + 1, top + 1, w->size - top - 1);
- }
- else
- {
- xv = gsl_matrix_subrow(R, j, 1, N - 1);
- yv = gsl_matrix_subrow(R, j + 1, 1, N - 1);
- }
- gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
- if (w->Q)
- {
- xv = gsl_matrix_column(w->Q, top + j);
- yv = gsl_matrix_column(w->Q, top + j + 1);
- gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
- }
- } /* gen_tri_split_top() */
- /*
- gen_tri_chase_zero()
- This routine is called when an element on the diagonal of R
- has become negligible. Chase the zero to the bottom of the active
- block so we can split off a 1-by-1 block.
- Inputs: H - upper hessenberg matrix
- R - upper triangular matrix
- q - index such that R(q,q) = 0 (q must be > 0)
- w - workspace
- */
- static inline void
- gen_tri_chase_zero(gsl_matrix *H, gsl_matrix *R, size_t q,
- gsl_eigen_gen_workspace *w)
- {
- const size_t N = H->size1;
- size_t j, top;
- double cs, sn;
- gsl_vector_view xv, yv;
- if (w->needtop)
- top = gen_get_submatrix(w->H, H);
- for (j = q; j < N - 1; ++j)
- {
- create_givens(gsl_matrix_get(R, j, j + 1),
- gsl_matrix_get(R, j + 1, j + 1),
- &cs,
- &sn);
- sn = -sn;
- if (w->compute_t)
- {
- xv = gsl_matrix_subrow(w->R, top + j, top + j + 1, w->size - top - j - 1);
- yv = gsl_matrix_subrow(w->R, top + j + 1, top + j + 1, w->size - top - j - 1);
- }
- else
- {
- xv = gsl_matrix_subrow(R, j, j + 1, N - j - 1);
- yv = gsl_matrix_subrow(R, j + 1, j + 1, N - j - 1);
- }
- gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
- gsl_matrix_set(R, j + 1, j + 1, 0.0);
- if (w->compute_s)
- {
- xv = gsl_matrix_subrow(w->H, top + j, top + j - 1, w->size - top - j + 1);
- yv = gsl_matrix_subrow(w->H, top + j + 1, top + j - 1, w->size - top - j + 1);
- }
- else
- {
- xv = gsl_matrix_subrow(H, j, j - 1, N - j + 1);
- yv = gsl_matrix_subrow(H, j + 1, j - 1, N - j + 1);
- }
- gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
- if (w->Q)
- {
- /* accumulate Q */
- xv = gsl_matrix_column(w->Q, top + j);
- yv = gsl_matrix_column(w->Q, top + j + 1);
- gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
- }
- create_givens(gsl_matrix_get(H, j + 1, j),
- gsl_matrix_get(H, j + 1, j - 1),
- &cs,
- &sn);
- sn = -sn;
- if (w->compute_s)
- {
- xv = gsl_matrix_subcolumn(w->H, top + j, 0, top + j + 2);
- yv = gsl_matrix_subcolumn(w->H, top + j - 1, 0, top + j + 2);
- }
- else
- {
- xv = gsl_matrix_subcolumn(H, j, 0, j + 2);
- yv = gsl_matrix_subcolumn(H, j - 1, 0, j + 2);
- }
- gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
- gsl_matrix_set(H, j + 1, j - 1, 0.0);
- if (w->compute_t)
- {
- xv = gsl_matrix_subcolumn(w->R, top + j, 0, top + j + 1);
- yv = gsl_matrix_subcolumn(w->R, top + j - 1, 0, top + j + 1);
- }
- else
- {
- xv = gsl_matrix_subcolumn(R, j, 0, j + 1);
- yv = gsl_matrix_subcolumn(R, j - 1, 0, j + 1);
- }
- gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
- if (w->Z)
- {
- /* accumulate Z */
- xv = gsl_matrix_column(w->Z, top + j);
- yv = gsl_matrix_column(w->Z, top + j - 1);
- gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
- }
- }
- } /* gen_tri_chase_zero() */
- /*
- gen_tri_zero_H()
- Companion function to get_tri_chase_zero(). After the zero on
- the diagonal of R has been chased to the bottom, we zero the element
- H(n, n - 1) in order to split off a 1-by-1 block.
- */
- static inline void
- gen_tri_zero_H(gsl_matrix *H, gsl_matrix *R, gsl_eigen_gen_workspace *w)
- {
- const size_t N = H->size1;
- size_t top;
- double cs, sn;
- gsl_vector_view xv, yv;
- if (w->needtop)
- top = gen_get_submatrix(w->H, H);
- create_givens(gsl_matrix_get(H, N - 1, N - 1),
- gsl_matrix_get(H, N - 1, N - 2),
- &cs,
- &sn);
- sn = -sn;
- if (w->compute_s)
- {
- xv = gsl_matrix_subcolumn(w->H, top + N - 1, 0, top + N);
- yv = gsl_matrix_subcolumn(w->H, top + N - 2, 0, top + N);
- }
- else
- {
- xv = gsl_matrix_column(H, N - 1);
- yv = gsl_matrix_column(H, N - 2);
- }
- gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
- gsl_matrix_set(H, N - 1, N - 2, 0.0);
- if (w->compute_t)
- {
- xv = gsl_matrix_subcolumn(w->R, top + N - 1, 0, top + N - 1);
- yv = gsl_matrix_subcolumn(w->R, top + N - 2, 0, top + N - 1);
- }
- else
- {
- xv = gsl_matrix_subcolumn(R, N - 1, 0, N - 1);
- yv = gsl_matrix_subcolumn(R, N - 2, 0, N - 1);
- }
- gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
- if (w->Z)
- {
- /* accumulate Z */
- xv = gsl_matrix_column(w->Z, top + N - 1);
- yv = gsl_matrix_column(w->Z, top + N - 2);
- gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
- }
- } /* gen_tri_zero_H() */
- /*
- gen_search_small_elements()
- This routine searches for small elements in the matrix pencil
- (H, R) to determine if any eigenvalues have converged.
- Tests:
- 1. Test if the Hessenberg matrix has a small subdiagonal element:
- H(i, i - 1) < tolerance
- 2. Test if the Triangular matrix has a small diagonal element:
- R(i, i) < tolerance
- Possible outcomes:
- (A) Neither test passed: in this case 'flag' is set to 0 and the
- function returns 0
- (B) Test 1 passes and 2 does not: in this case 'flag' is set to 1
- and we return the row index i such that H(i, i - 1) < tol
- (C) Test 2 passes and 1 does not: in this case 'flag' is set to 2
- and we return the index i such that R(i, i) < tol
- (D) Tests 1 and 2 both pass: in this case 'flag' is set to 3 and
- we return the index i such that H(i, i - 1) < tol and R(i, i) < tol
- Inputs: H - upper Hessenberg matrix
- R - upper Triangular matrix
- flag - (output) flag set on output (see above)
- w - workspace
- Return: see above
- */
- static inline size_t
- gen_search_small_elements(gsl_matrix *H, gsl_matrix *R,
- int *flag, gsl_eigen_gen_workspace *w)
- {
- const size_t N = H->size1;
- int k;
- size_t i;
- int pass1 = 0;
- int pass2 = 0;
- for (k = (int) N - 1; k >= 0; --k)
- {
- i = (size_t) k;
- if (i != 0 && fabs(gsl_matrix_get(H, i, i - 1)) <= w->atol)
- {
- gsl_matrix_set(H, i, i - 1, 0.0);
- pass1 = 1;
- }
- if (fabs(gsl_matrix_get(R, i, i)) < w->btol)
- {
- gsl_matrix_set(R, i, i, 0.0);
- pass2 = 1;
- }
- if (pass1 && !pass2) /* case B */
- {
- *flag = 1;
- return (i);
- }
- else if (!pass1 && pass2) /* case C */
- {
- *flag = 2;
- return (i);
- }
- else if (pass1 && pass2) /* case D */
- {
- *flag = 3;
- return (i);
- }
- }
- /* neither test passed: case A */
- *flag = 0;
- return (0);
- } /* gen_search_subdiag_small_elements() */
- /*
- gen_schur_standardize1()
- This function is called when a 1-by-1 block has converged -
- convert the block to standard form and update the Schur forms and
- vectors if required. Standard form here means that the diagonal
- element of B is positive.
- Inputs: A - 1-by-1 matrix in Schur form S
- B - 1-by-1 matrix in Schur form T
- alphar - where to store real part of eigenvalue numerator
- beta - where to store eigenvalue denominator
- w - workspace
- Return: success
- */
- static int
- gen_schur_standardize1(gsl_matrix *A, gsl_matrix *B, double *alphar,
- double *beta, gsl_eigen_gen_workspace *w)
- {
- size_t i;
- size_t top;
- /*
- * it is a 1-by-1 block - the only requirement is that
- * B_{00} is > 0, so if it isn't apply a -I transformation
- */
- if (gsl_matrix_get(B, 0, 0) < 0.0)
- {
- if (w->needtop)
- top = gen_get_submatrix(w->H, A);
- if (w->compute_t)
- {
- for (i = 0; i <= top; ++i)
- gsl_matrix_set(w->R, i, top, -gsl_matrix_get(w->R, i, top));
- }
- else
- gsl_matrix_set(B, 0, 0, -gsl_matrix_get(B, 0, 0));
- if (w->compute_s)
- {
- for (i = 0; i <= top; ++i)
- gsl_matrix_set(w->H, i, top, -gsl_matrix_get(w->H, i, top));
- }
- else
- gsl_matrix_set(A, 0, 0, -gsl_matrix_get(A, 0, 0));
- if (w->Z)
- {
- for (i = 0; i < w->size; ++i)
- gsl_matrix_set(w->Z, i, top, -gsl_matrix_get(w->Z, i, top));
- }
- }
- *alphar = gsl_matrix_get(A, 0, 0);
- *beta = gsl_matrix_get(B, 0, 0);
- return GSL_SUCCESS;
- } /* gen_schur_standardize1() */
- /*
- gen_schur_standardize2()
- This function is called when a 2-by-2 generalized block has
- converged. Convert the block to standard form, which means B
- is rotated so that
- B = [ B11 0 ] with B11, B22 non-negative
- [ 0 B22 ]
- If the resulting block (A, B) has complex eigenvalues, they are
- computed. Otherwise, the function will return GSL_CONTINUE to
- notify caller that we need to do more single shift sweeps to
- convert the 2-by-2 block into two 1-by-1 blocks.
- Inputs: A - 2-by-2 submatrix of schur form S
- B - 2-by-2 submatrix of schur form T
- alpha1 - (output) where to store eigenvalue 1 numerator
- alpha2 - (output) where to store eigenvalue 2 numerator
- beta1 - (output) where to store eigenvalue 1 denominator
- beta2 - (output) where to store eigenvalue 2 denominator
- w - workspace
- Return: GSL_SUCCESS if block has complex eigenvalues (they are computed)
- GSL_CONTINUE if block has real eigenvalues (they are not computed)
- */
- static int
- gen_schur_standardize2(gsl_matrix *A, gsl_matrix *B, gsl_complex *alpha1,
- gsl_complex *alpha2, double *beta1, double *beta2,
- gsl_eigen_gen_workspace *w)
- {
- double datB[4],
- datV[4],
- datS[2],
- work[2];
- gsl_matrix_view uv = gsl_matrix_view_array(datB, 2, 2);
- gsl_matrix_view vv = gsl_matrix_view_array(datV, 2, 2);
- gsl_vector_view sv = gsl_vector_view_array(datS, 2);
- gsl_vector_view wv = gsl_vector_view_array(work, 2);
- double B11, B22;
- size_t top;
- double det;
- double cr, sr, cl, sl;
- gsl_vector_view xv, yv;
- int s;
- if (w->needtop)
- top = gen_get_submatrix(w->H, A);
- /*
- * Rotate B so that
- *
- * B = [ B11 0 ]
- * [ 0 B22 ]
- *
- * with B11 non-negative
- */
- gsl_matrix_memcpy(&uv.matrix, B);
- gsl_linalg_SV_decomp(&uv.matrix, &vv.matrix, &sv.vector, &wv.vector);
- /*
- * Right now, B = U S V^t, where S = diag(s)
- *
- * The SVD routine may have computed reflection matrices U and V,
- * but it would be much nicer to have rotations since we won't have
- * to use BLAS mat-mat multiplications to update our matrices,
- * and can instead use drot. So convert them to rotations if
- * necessary
- */
- det = gsl_matrix_get(&vv.matrix, 0, 0) * gsl_matrix_get(&vv.matrix, 1, 1) -
- gsl_matrix_get(&vv.matrix, 0, 1) * gsl_matrix_get(&vv.matrix, 1, 0);
- if (det < 0.0)
- {
- /* V is a reflection, convert it to a rotation by inserting
- * F = [1 0; 0 -1] so that:
- *
- * B = U S [1 0] [1 0] V^t
- * [0 -1] [0 -1]
- *
- * so S -> S F and V -> V F where F is the reflection matrix
- * We just need to invert S22 since the first column of V
- * will remain unchanged and we can just read off the CS and SN
- * parameters.
- */
- datS[1] = -datS[1];
- }
- cr = gsl_matrix_get(&vv.matrix, 0, 0);
- sr = gsl_matrix_get(&vv.matrix, 1, 0);
- /* same for U */
- det = gsl_matrix_get(&uv.matrix, 0, 0) * gsl_matrix_get(&uv.matrix, 1, 1) -
- gsl_matrix_get(&uv.matrix, 0, 1) * gsl_matrix_get(&uv.matrix, 1, 0);
- if (det < 0.0)
- datS[1] = -datS[1];
- cl = gsl_matrix_get(&uv.matrix, 0, 0);
- sl = gsl_matrix_get(&uv.matrix, 1, 0);
- B11 = gsl_vector_get(&sv.vector, 0);
- B22 = gsl_vector_get(&sv.vector, 1);
- /* make sure B11 is positive */
- if (B11 < 0.0)
- {
- B11 = -B11;
- B22 = -B22;
- cr = -cr;
- sr = -sr;
- }
- /*
- * At this point,
- *
- * [ S11 0 ] = [ CSL SNL ] B [ CSR -SNR ]
- * [ 0 S22 ] [-SNL CSL ] [ SNR CSR ]
- *
- * apply rotations to H and rest of R
- */
- if (w->compute_s)
- {
- xv = gsl_matrix_subrow(w->H, top, top, w->size - top);
- yv = gsl_matrix_subrow(w->H, top + 1, top, w->size - top);
- gsl_blas_drot(&xv.vector, &yv.vector, cl, sl);
- xv = gsl_matrix_subcolumn(w->H, top, 0, top + 2);
- yv = gsl_matrix_subcolumn(w->H, top + 1, 0, top + 2);
- gsl_blas_drot(&xv.vector, &yv.vector, cr, sr);
- }
- else
- {
- xv = gsl_matrix_row(A, 0);
- yv = gsl_matrix_row(A, 1);
- gsl_blas_drot(&xv.vector, &yv.vector, cl, sl);
- xv = gsl_matrix_column(A, 0);
- yv = gsl_matrix_column(A, 1);
- gsl_blas_drot(&xv.vector, &yv.vector, cr, sr);
- }
- if (w->compute_t)
- {
- if (top != (w->size - 2))
- {
- xv = gsl_matrix_subrow(w->R, top, top + 2, w->size - top - 2);
- yv = gsl_matrix_subrow(w->R, top + 1, top + 2, w->size - top - 2);
- gsl_blas_drot(&xv.vector, &yv.vector, cl, sl);
- }
- if (top != 0)
- {
- xv = gsl_matrix_subcolumn(w->R, top, 0, top);
- yv = gsl_matrix_subcolumn(w->R, top + 1, 0, top);
- gsl_blas_drot(&xv.vector, &yv.vector, cr, sr);
- }
- }
- if (w->Q)
- {
- xv = gsl_matrix_column(w->Q, top);
- yv = gsl_matrix_column(w->Q, top + 1);
- gsl_blas_drot(&xv.vector, &yv.vector, cl, sl);
- }
- if (w->Z)
- {
- xv = gsl_matrix_column(w->Z, top);
- yv = gsl_matrix_column(w->Z, top + 1);
- gsl_blas_drot(&xv.vector, &yv.vector, cr, sr);
- }
- gsl_matrix_set(B, 0, 0, B11);
- gsl_matrix_set(B, 0, 1, 0.0);
- gsl_matrix_set(B, 1, 0, 0.0);
- gsl_matrix_set(B, 1, 1, B22);
- /* if B22 is < 0, make it positive by negating its column */
- if (B22 < 0.0)
- {
- size_t i;
- if (w->compute_s)
- {
- for (i = 0; i < top + 2; ++i)
- gsl_matrix_set(w->H, i, top + 1, -gsl_matrix_get(w->H, i, top + 1));
- }
- else
- {
- gsl_matrix_set(A, 0, 1, -gsl_matrix_get(A, 0, 1));
- gsl_matrix_set(A, 1, 1, -gsl_matrix_get(A, 1, 1));
- }
- if (w->compute_t)
- {
- for (i = 0; i < top + 2; ++i)
- gsl_matrix_set(w->R, i, top + 1, -gsl_matrix_get(w->R, i, top + 1));
- }
- else
- {
- gsl_matrix_set(B, 0, 1, -gsl_matrix_get(B, 0, 1));
- gsl_matrix_set(B, 1, 1, -gsl_matrix_get(B, 1, 1));
- }
- if (w->Z)
- {
- xv = gsl_matrix_column(w->Z, top + 1);
- gsl_vector_scale(&xv.vector, -1.0);
- }
- }
- /* our block is now in standard form - compute eigenvalues */
- s = gen_compute_eigenvals(A, B, alpha1, alpha2, beta1, beta2);
- return s;
- } /* gen_schur_standardize2() */
- /*
- gen_compute_eigenvals()
- Compute the complex eigenvalues of a 2-by-2 block
- Return: GSL_CONTINUE if block contains real eigenvalues (they are not
- computed)
- GSL_SUCCESS on normal completion
- */
- static int
- gen_compute_eigenvals(gsl_matrix *A, gsl_matrix *B, gsl_complex *alpha1,
- gsl_complex *alpha2, double *beta1, double *beta2)
- {
- double wr1, wr2, wi, scale1, scale2;
- double s1inv;
- double A11, A12, A21, A22;
- double B11, B22;
- double c11r, c11i, c12, c21, c22r, c22i;
- double cz, cq;
- double szr, szi, sqr, sqi;
- double a1r, a1i, a2r, a2i, b1r, b1i, b1a, b2r, b2i, b2a;
- double alphar, alphai;
- double t1, an, bn, tempr, tempi, wabs;
- /*
- * This function is called from gen_schur_standardize2() and
- * its possible the standardization has perturbed the eigenvalues
- * onto the real line - so check for this before computing them
- */
- gsl_schur_gen_eigvals(A, B, &wr1, &wr2, &wi, &scale1, &scale2);
- if (wi == 0.0)
- return GSL_CONTINUE; /* real eigenvalues - continue QZ iteration */
- /* complex eigenvalues - compute alpha and beta */
- s1inv = 1.0 / scale1;
- A11 = gsl_matrix_get(A, 0, 0);
- A12 = gsl_matrix_get(A, 0, 1);
- A21 = gsl_matrix_get(A, 1, 0);
- A22 = gsl_matrix_get(A, 1, 1);
- B11 = gsl_matrix_get(B, 0, 0);
- B22 = gsl_matrix_get(B, 1, 1);
- c11r = scale1 * A11 - wr1 * B11;
- c11i = -wi * B11;
- c12 = scale1 * A12;
- c21 = scale1 * A21;
- c22r = scale1 * A22 - wr1 * B22;
- c22i = -wi * B22;
- if (fabs(c11r) + fabs(c11i) + fabs(c12) >
- fabs(c21) + fabs(c22r) + fabs(c22i))
- {
- t1 = gsl_hypot3(c12, c11r, c11i);
- if (t1 != 0.0)
- {
- cz = c12 / t1;
- szr = -c11r / t1;
- szi = -c11i / t1;
- }
- else
- {
- cz = 0.0;
- szr = 1.0;
- szi = 0.0;
- }
- }
- else
- {
- cz = hypot(c22r, c22i);
- if (cz <= GSL_DBL_MIN)
- {
- cz = 0.0;
- szr = 1.0;
- szi = 0.0;
- }
- else
- {
- tempr = c22r / cz;
- tempi = c22i / cz;
- t1 = hypot(cz, c21);
- cz /= t1;
- szr = -c21*tempr / t1;
- szi = c21*tempi / t1;
- }
- }
- an = fabs(A11) + fabs(A12) + fabs(A21) + fabs(A22);
- bn = fabs(B11) + fabs(B22);
- wabs = fabs(wr1) + fabs(wi);
- if (scale1*an > wabs*bn)
- {
- cq = cz * B11;
- if (cq <= GSL_DBL_MIN)
- {
- cq = 0.0;
- sqr = 1.0;
- sqi = 0.0;
- }
- else
- {
- sqr = szr * B22;
- sqi = -szi * B22;
- }
- }
- else
- {
- a1r = cz * A11 + szr * A12;
- a1i = szi * A12;
- a2r = cz * A21 + szr * A22;
- a2i = szi * A22;
- cq = hypot(a1r, a1i);
- if (cq <= GSL_DBL_MIN)
- {
- cq = 0.0;
- sqr = 1.0;
- sqi = 0.0;
- }
- else
- {
- tempr = a1r / cq;
- tempi = a1i / cq;
- sqr = tempr * a2r + tempi * a2i;
- sqi = tempi * a2r - tempr * a2i;
- }
- }
- t1 = gsl_hypot3(cq, sqr, sqi);
- cq /= t1;
- sqr /= t1;
- sqi /= t1;
- tempr = sqr*szr - sqi*szi;
- tempi = sqr*szi + sqi*szr;
- b1r = cq*cz*B11 + tempr*B22;
- b1i = tempi*B22;
- b1a = hypot(b1r, b1i);
- b2r = cq*cz*B22 + tempr*B11;
- b2i = -tempi*B11;
- b2a = hypot(b2r, b2i);
- *beta1 = b1a;
- *beta2 = b2a;
-
- alphar = (wr1 * b1a) * s1inv;
- alphai = (wi * b1a) * s1inv;
- GSL_SET_COMPLEX(alpha1, alphar, alphai);
- alphar = (wr1 * b2a) * s1inv;
- alphai = -(wi * b2a) * s1inv;
- GSL_SET_COMPLEX(alpha2, alphar, alphai);
- return GSL_SUCCESS;
- } /* gen_compute_eigenvals() */
- /*
- gen_store_eigval1()
- Store eigenvalue of a 1-by-1 block into the alpha and beta
- output vectors. This routine ensures that eigenvalues are stored
- in the same order as they appear in the Schur form and updates
- various internal workspace quantities.
- */
- static void
- gen_store_eigval1(const gsl_matrix *H, const double a, const double b,
- gsl_vector_complex *alpha,
- gsl_vector *beta, gsl_eigen_gen_workspace *w)
- {
- size_t top = gen_get_submatrix(w->H, H);
- gsl_complex z;
- GSL_SET_COMPLEX(&z, a, 0.0);
- gsl_vector_complex_set(alpha, top, z);
- gsl_vector_set(beta, top, b);
- w->n_evals += 1;
- w->n_iter = 0;
- w->eshift = 0.0;
- } /* gen_store_eigval1() */
- /*
- gen_store_eigval2()
- Store eigenvalues of a 2-by-2 block into the alpha and beta
- output vectors. This routine ensures that eigenvalues are stored
- in the same order as they appear in the Schur form and updates
- various internal workspace quantities.
- */
- static void
- gen_store_eigval2(const gsl_matrix *H, const gsl_complex *alpha1,
- const double beta1, const gsl_complex *alpha2,
- const double beta2, gsl_vector_complex *alpha,
- gsl_vector *beta, gsl_eigen_gen_workspace *w)
- {
- size_t top = gen_get_submatrix(w->H, H);
- gsl_vector_complex_set(alpha, top, *alpha1);
- gsl_vector_set(beta, top, beta1);
- gsl_vector_complex_set(alpha, top + 1, *alpha2);
- gsl_vector_set(beta, top + 1, beta2);
- w->n_evals += 2;
- w->n_iter = 0;
- w->eshift = 0.0;
- } /* gen_store_eigval2() */
- /*
- gen_get_submatrix()
- B is a submatrix of A. The goal of this function is to
- compute the indices in A of where the matrix B resides
- */
- static inline size_t
- gen_get_submatrix(const gsl_matrix *A, const gsl_matrix *B)
- {
- size_t diff;
- double ratio;
- size_t top;
- diff = (size_t) (B->data - A->data);
- /* B is on the diagonal of A, so measure distance in units of
- tda+1 */
- ratio = (double)diff / ((double) (A->tda + 1));
- top = (size_t) floor(ratio);
- return top;
- } /* gen_get_submatrix() */
- /* Frobenius norm */
- inline static double
- normF (gsl_matrix * A)
- {
- size_t i, j, M = A->size1, N = A->size2;
- double sum = 0.0, scale = 0.0, ssq = 1.0;
- for (i = 0; i < M; i++)
- {
- for (j = 0; j < N; j++)
- {
- double Aij = gsl_matrix_get (A, i, j);
- if (Aij != 0.0)
- {
- double ax = fabs (Aij);
- if (scale < ax)
- {
- ssq = 1.0 + ssq * (scale / ax) * (scale / ax);
- scale = ax;
- }
- else
- {
- ssq += (ax / scale) * (ax / scale);
- }
- }
- }
- }
- sum = scale * sqrt (ssq);
- return sum;
- }
- /* Generate a Givens rotation (cos,sin) which takes v=(x,y) to (|v|,0)
- From Golub and Van Loan, "Matrix Computations", Section 5.1.8 */
- inline static void
- create_givens (const double a, const double b, double *c, double *s)
- {
- if (b == 0)
- {
- *c = 1;
- *s = 0;
- }
- else if (fabs (b) > fabs (a))
- {
- double t = -a / b;
- double s1 = 1.0 / sqrt (1 + t * t);
- *s = s1;
- *c = s1 * t;
- }
- else
- {
- double t = -b / a;
- double c1 = 1.0 / sqrt (1 + t * t);
- *c = c1;
- *s = c1 * t;
- }
- }
|