From: <par...@us...> - 2009-11-08 11:07:34
|
Revision: 6451 http://octave.svn.sourceforge.net/octave/?rev=6451&view=rev Author: paramaniac Date: 2009-11-08 11:07:26 +0000 (Sun, 08 Nov 2009) Log Message: ----------- control-oo: add norm Modified Paths: -------------- trunk/octave-forge/extra/control-oo/INDEX trunk/octave-forge/extra/control-oo/inst/control/ltimodels.m Added Paths: ----------- trunk/octave-forge/extra/control-oo/inst/@lti/norm.m Modified: trunk/octave-forge/extra/control-oo/INDEX =================================================================== --- trunk/octave-forge/extra/control-oo/INDEX 2009-11-08 09:11:32 UTC (rev 6450) +++ trunk/octave-forge/extra/control-oo/INDEX 2009-11-08 11:07:26 UTC (rev 6451) @@ -22,6 +22,7 @@ strseq System Gain and Dynamics dcgain + norm pole zero Time Domain Analysis Added: trunk/octave-forge/extra/control-oo/inst/@lti/norm.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/@lti/norm.m (rev 0) +++ trunk/octave-forge/extra/control-oo/inst/@lti/norm.m 2009-11-08 11:07:26 UTC (rev 6451) @@ -0,0 +1,170 @@ +## Copyright (C) 1996, 1998, 2000, 2002, 2004, 2005, 2006, 2007 +## Auburn University. All rights reserved. +## +## +## 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; see the file COPYING. If not, see +## <http://www.gnu.org/licenses/>. + +## -*- texinfo -*- +## @deftypefn {Function File} {@var{gain} =} norm (@var{sys}, @var{2}) +## @deftypefnx {Function File} {@var{gain} =} norm (@var{sys}, @var{inf}) +## @deftypefnx {Function File} {@var{gain} =} norm (@var{sys}, @var{inf}, @var{tol}) +## Return norm of LTI model. +## @end deftypefn + +## Author: A. S. Hodel <a.s...@en...> +## Created: August 1995 +## Reference: Doyle, Glover, Khargonekar, Francis +## State-Space Solutions to Standard Control Problems +## IEEE TAC August 1989 + +## Adapted-By: Lukas Reichlin <luk...@gm...> +## Date: November 2009 +## Version: 0.1 + +function gain = norm (sys, ntype = "2", tol = 0.001) + + if (nargin > 3) # norm () is catched by built-in function + print_usage (); + endif + + if (isnumeric (ntype) && isscalar (ntype)) + if (ntype == 2) + ntype = "2"; + elseif (isinf (ntype)) + ntype = "inf"; + else + error ("lti: norm: invalid norm type"); + endif + elseif (ischar (ntype)) + ntype = lower (ntype); + else + error ("lti: norm: invalid norm type"); + endif + + switch (ntype) + case "2" + gain = h2norm (sys); + + case "inf" + gain = hinfnorm (sys, tol); + + otherwise + error ("lti: norm: invalid norm type"); + endswitch + +endfunction + + +function gain = h2norm (sys) + + if (isstable (sys)) + [a, b, c, d] = ssdata (sys); + + if (isct (sys)) + M = lyap (a, b*b'); + else + M = dlyap (a, b*b'); + endif + + if (min (real (eig (M))) < 0) + error ("norm: H2: gramian < 0 (lightly damped modes?)") + endif + + gain = sqrt (trace (d*d' + c*M*c')); + else + warning ("norm: H2: unstable input system; returning Inf"); + gain = Inf; + endif + +endfunction + + +function g = hinfnorm (sys, tol = 0.001, gmin = 1e-9, gmax = 1e9, ptol = 1e-9) + + if (isstable (sys)) + + [A, B, C, D, tsam] = ssdata (sys); + n = rows (A); # states + m = columns (B); # inputs + p = rows (C); # outputs + dflg = (tsam > 0); + + Dnrm = norm (D); + if (nargin < 3) + gmin = max (gmin, Dnrm); # min gain value + elseif (gmin < Dnrm) + warning ("hinfnorm: setting Gmin=||D||=%g", Dnrm); + endif + + In = eye (n); + Im = eye (m); + Ip = eye (p); + + ## find the Hinf norm via binary search + while (gmax/gmin - 1 > tol) + g = (gmax+gmin)/2; + + if (dflg) + ## multiply g's through in formulas to avoid extreme magnitudes... + Rg = g^2*Im - D'*D; + Ak = A + (B/Rg)*D'*C; + Ck = g^2*C'*((g^2*Ip-D*D')\C); + + ## set up symplectic generalized eigenvalue problem per Iglesias & Glover + s1 = [Ak , zeros(n); -Ck, In]; + s2 = [In, -(B/Rg)*B'; zeros(n), Ak']; + + ## guard against roundoff again: zero out extremely small values + ## prior to balancing + s1 = s1 .* (abs(s1) > ptol*norm(s1,"inf")); + s2 = s2 .* (abs(s2) > ptol*norm(s2,"inf")); + [cc, dd, s1, s2] = balance (s1, s2); + [qza, qzb, zz, pls] = qz (s1, s2, "S"); # ordered qz decomposition + eigerr = abs (abs(pls)-1); + normH = norm ([s1, s2]); + Hb = [s1, s2]; + + ## check R - B' X B condition (Iglesias and Glover's paper) + X = zz((n+1):(2*n),1:n)/zz(1:n,1:n); + dcondfailed = min (real (eig (Rg - B'*X*B)) < ptol); + else + Rinv = inv(g*g*Im - (D' * D)); + H = [A + B*Rinv*D'*C, B*Rinv*B'; + -C'*(Ip + D*Rinv*D')*C, -(A + B*Rinv*D'*C)']; + + ## guard against roundoff: zero out extremely small values prior + ## to balancing + H = H .* (abs (H) > ptol * norm (H, "inf")); + [DD, Hb] = balance (H); + pls = eig (Hb); + eigerr = abs (real (pls)); + normH = norm (H); + dcondfailed = 0; # digital condition; doesn't apply here + endif + + if ((min (eigerr) <= ptol * normH) | dcondfailed) + gmin = g; + else + gmax = g; + endif + endwhile + + else + warning ("norm: Hinf: unstable system (ptol=%g), returning Inf", ptol); + g = Inf; + endif + +endfunction + Modified: trunk/octave-forge/extra/control-oo/inst/control/ltimodels.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/control/ltimodels.m 2009-11-08 09:11:32 UTC (rev 6450) +++ trunk/octave-forge/extra/control-oo/inst/control/ltimodels.m 2009-11-08 11:07:26 UTC (rev 6451) @@ -105,3 +105,27 @@ %! D_exp = [ 10 ]; %! sysmat_exp = [A_exp, B_exp; C_exp, D_exp]; %!assert (sysmat, sysmat_exp) + +## norm ct +%!shared H2, Hinf +%! sys = ss (-1, 1, 1, 0); +%! H2 = norm (sys, 2); +%! Hinf = norm (sys, inf); +%!assert (H2, 0.7071, 1.5e-5); +%!assert (Hinf, 1, 5e-4); + +## norm dt +%!shared H2, Hinf +%! a = [ 2.417 -1.002 0.5488 +%! 2 0 0 +%! 0 0.5 0 ]; +%! b = [ 1 +%! 0 +%! 0 ]; +%! c = [-0.424 0.436 -0.4552 ]; +%! d = [ 1 ]; +%! sys = ss (a, b, c, d, 0.1); +%! H2 = norm (sys, 2); +%! Hinf = norm (sys, inf); +%!assert (H2, 1.2527, 1.5e-5); +%!assert (Hinf, 2.7, 0.1); This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <par...@us...> - 2009-11-10 13:41:43
|
Revision: 6458 http://octave.svn.sourceforge.net/octave/?rev=6458&view=rev Author: paramaniac Date: 2009-11-10 13:41:22 +0000 (Tue, 10 Nov 2009) Log Message: ----------- control-oo: add pzmap Modified Paths: -------------- trunk/octave-forge/extra/control-oo/INDEX Added Paths: ----------- trunk/octave-forge/extra/control-oo/inst/control/pzmap.m Modified: trunk/octave-forge/extra/control-oo/INDEX =================================================================== --- trunk/octave-forge/extra/control-oo/INDEX 2009-11-10 11:24:22 UTC (rev 6457) +++ trunk/octave-forge/extra/control-oo/INDEX 2009-11-10 13:41:22 UTC (rev 6458) @@ -24,6 +24,7 @@ dcgain norm pole + pzmap zero Time Domain Analysis gensig Added: trunk/octave-forge/extra/control-oo/inst/control/pzmap.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/control/pzmap.m (rev 0) +++ trunk/octave-forge/extra/control-oo/inst/control/pzmap.m 2009-11-10 13:41:22 UTC (rev 6458) @@ -0,0 +1,57 @@ +## Copyright (C) 2009 Lukas F. Reichlin +## +## This file is part of LTI Syncope. +## +## LTI Syncope 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. +## +## LTI Syncope 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, see <http://www.gnu.org/licenses/>. + +## -*- texinfo -*- +## @deftypefn {Function File} pzmap (@var{sys}) +## @deftypefnx {Function File} {[@var{p}, @var{z}] =} pzmap (@var{sys}) +## Plot the poles and zeros of a LTI system in the complex plane. +## @end deftypefn + +## Author: Lukas Reichlin <luk...@gm...> +## Created: November 2009 +## Version: 0.1 + +function [pol_r, zer_r] = pzmap (sys) + + if (nargin != 1) + print_usage (); + endif + + if (! isa (sys, "lti")) + error ("pzmap: argument must be a LTI system"); + endif + + pol = pole (sys); + zer = zero (sys); + + if (! nargout) + pol_re = real (pol); + pol_im = imag (pol); + zer_re = real (zer); + zer_im = imag (zer); + + plot (pol_re, pol_im, "xb", zer_re, zer_im, "sr") + grid ("on") + title ("Pole-Zero Map") + xlabel ("Real Axis") + ylabel ("Imaginary Axis") + else + pol_r = pol; + zer_r = zer; + endif + +endfunction \ No newline at end of file This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <par...@us...> - 2009-11-17 14:31:39
|
Revision: 6480 http://octave.svn.sourceforge.net/octave/?rev=6480&view=rev Author: paramaniac Date: 2009-11-17 14:31:07 +0000 (Tue, 17 Nov 2009) Log Message: ----------- control-oo: update ARE soivers Modified Paths: -------------- trunk/octave-forge/extra/control-oo/INDEX trunk/octave-forge/extra/control-oo/inst/control/are.m trunk/octave-forge/extra/control-oo/inst/control/care.m trunk/octave-forge/extra/control-oo/inst/control/dare.m Added Paths: ----------- trunk/octave-forge/extra/control-oo/inst/control/isdetectable.m trunk/octave-forge/extra/control-oo/inst/control/isstabilizable.m Modified: trunk/octave-forge/extra/control-oo/INDEX =================================================================== --- trunk/octave-forge/extra/control-oo/INDEX 2009-11-17 10:10:07 UTC (rev 6479) +++ trunk/octave-forge/extra/control-oo/INDEX 2009-11-17 14:31:07 UTC (rev 6480) @@ -46,6 +46,7 @@ Compensator Design place LQR/LQG Design + dlqr lqr Controller Synthesis State-Space Models @@ -70,6 +71,8 @@ inv Matrix Equation Solvers are + care + dare dlyap lyap Octave-only Modified: trunk/octave-forge/extra/control-oo/inst/control/are.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/control/are.m 2009-11-17 10:10:07 UTC (rev 6479) +++ trunk/octave-forge/extra/control-oo/inst/control/are.m 2009-11-17 14:31:07 UTC (rev 6480) @@ -101,7 +101,7 @@ endif if (! m) - b = b * b'; + b = b * b'; # b must be symmetric m = rows (b); endif @@ -109,8 +109,11 @@ warning ("are: matrices a and c are not observable"); endif + ## to allow lqe design, don't force + ## b to be positive semi-definite + if (! p) - c = c' * c; + c = c' * c; # c must be symmetric p = rows (c); endif Modified: trunk/octave-forge/extra/control-oo/inst/control/care.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/control/care.m 2009-11-17 10:10:07 UTC (rev 6479) +++ trunk/octave-forge/extra/control-oo/inst/control/care.m 2009-11-17 14:31:07 UTC (rev 6480) @@ -23,37 +23,66 @@ function [x, l, g] = care (a, b, q, r, s = [], opt = "B") - warning ("care: under construction"); - if (nargin < 4 || nargin > 6) print_usage (); endif + if (nargin == 6) + if (ischar (opt)) + opt = upper (opt(1)); + if (opt != "B" && opt != N && opt != "P" && opt != "S") + warning ("dare: opt has invalid value ""%s""; setting to ""B""", opt); + opt = "B"; + endif + else + warning ("dare: invalid argument opt, setting to ""B"""); + opt = "B"; + endif + endif [n, m] = size (b); + p = issquare (q); + m1 = issquare (r); + if (! m1) + error ("care: r is not square"); + elseif (m1 != m) + error ("care: b, r are not conformable"); + endif + + if (! p) + q = q' * q; + endif + ## incorporate cross term into a and q if (isempty (s)) s = zeros (n, m); ao = a; qo = q; else - [n1, m1] = size (s); - if (n1 != n || m1 != m) - error ("care: s must be identically dimensioned with b"); + [n2, m2] = size (s); + + if (n2 != n || m2 != m) + error ("cs (%dx%d) must be identically dimensioned with b (%dx%d)", + n2, m2, n, m); endif ao = a - (b/r)*s'; qo = q - (s/r)*s'; endif - ## check qo and r - if (! issymmetric (qo)) - error ("lqr: q must be symmetric"); + ## check stabilizability + if (! isstabilizable (ao, b, [], 0)) + error ("care: a and b not stabilizable"); endif - if (! issymmetric (r)) - error ("lqr: r must be symmetric"); + ## check detectability + dflag = isdetectable (ao, qo, [], 0); + + if (dflag == 0) + warning ("care: a and q not detectable"); + elseif (dflag == -1) + error ("care: a and q have poles on imaginary axis"); endif ## to allow lqe design, don't force Modified: trunk/octave-forge/extra/control-oo/inst/control/dare.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/control/dare.m 2009-11-17 10:10:07 UTC (rev 6479) +++ trunk/octave-forge/extra/control-oo/inst/control/dare.m 2009-11-17 14:31:07 UTC (rev 6480) @@ -81,8 +81,6 @@ function [x, l, g] = dare (a, b, q, r, s = [], opt = "B") - warning ("dare: under construction"); - if (nargin < 4 || nargin > 6) print_usage (); endif @@ -133,26 +131,26 @@ ## check stabilizability if (! isstabilizable (ao, b, [], 1)) - error ("dlqr: (a,b) not stabilizable"); + error ("dare: a and b not stabilizable"); endif ## check detectability dflag = isdetectable (ao, qo, [], 1); if (dflag == 0) - warning ("dlqr: (a,q) not detectable"); + warning ("dare: (a,q) not detectable"); elseif (dflag == -1) - error ("dlqr: (a,q) has non-minimal modes near unit circle"); + error ("dare: (a,q) has non-minimal modes near unit circle"); endif ## Checking positive definiteness if (isdefinite (r) <= 0) - error ("dare: r not positive definite"); + error ("dare: r must be positive definite"); endif - %if (isdefinite (qo) < 0) - % error ("dare: q not positive semidefinite"); - %endif + ## if (isdefinite (qo) < 0) + ## error ("dare: q not positive semidefinite"); + ## endif ## solve the riccati equation s1 = [ ao, zeros(n); Added: trunk/octave-forge/extra/control-oo/inst/control/isdetectable.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/control/isdetectable.m (rev 0) +++ trunk/octave-forge/extra/control-oo/inst/control/isdetectable.m 2009-11-17 14:31:07 UTC (rev 6480) @@ -0,0 +1,63 @@ +## Copyright (C) 1993, 1994, 1995, 2000, 2002, 2003, 2004, 2005, 2006, +## 2007 Auburn University. All rights reserved. +## +## +## 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; see the file COPYING. If not, see +## <http://www.gnu.org/licenses/>. + +## -*- texinfo -*- +## @deftypefn {Function File} {@var{retval} =} isdetectable (@var{a}, @var{c}, @var{tol}, @var{dflg}) +## @deftypefnx {Function File} {@var{retval} =} isdetectable (@var{sys}, @var{tol}) +## Test for detectability (observability of unstable modes) of (@var{a}, @var{c}). +## +## Returns 1 if the system @var{a} or the pair (@var{a}, @var{c}) is +## detectable, 0 if not, and -1 if the system has unobservable modes at the +## imaginary axis (unit circle for discrete-time systems). +## +## @strong{See} @command{is_stabilizable} for detailed description of +## arguments and computational method. +## @seealso{isstabilizable, size, rows, columns, length, ismatrix, isscalar, isvector} +## @end deftypefn + +## Author: A. S. Hodel <a.s...@en...> +## Created: August 1993 +## Updated by John Ingram (in...@en...) July 1996. + +## Adapted-By: Lukas Reichlin <luk...@gm...> +## Date: October 2009 +## Version: 0.1 + +function retval = isdetectable (a, c = [], tol = [], dflg = 0) + + if (nargin < 1) + print_usage (); + elseif (isa (a, "lti")) + ## system form + if (nargin == 2) + tol = c; + elseif (nargin > 2) + print_usage (); + endif + dflg = isdt (a); + [a, b, c] = ssdata (a); + else + if (nargin > 4 || nargin == 1) + print_usage (); + endif + endif + + retval = isstabilizable (a', c', tol, dflg); + +endfunction + Added: trunk/octave-forge/extra/control-oo/inst/control/isstabilizable.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/control/isstabilizable.m (rev 0) +++ trunk/octave-forge/extra/control-oo/inst/control/isstabilizable.m 2009-11-17 14:31:07 UTC (rev 6480) @@ -0,0 +1,126 @@ +## Copyright (C) 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 +## Kai P. Mueller. +## +## +## 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; see the file COPYING. If not, see +## <http://www.gnu.org/licenses/>. + +## -*- texinfo -*- +## @deftypefn {Function File} {@var{retval} =} isstabilizable (@var{sys}, @var{tol}) +## @deftypefnx {Function File} {@var{retval} =} isstabilizable (@var{a}, @var{b}, @var{tol}, @var{dflg}) +## Logical check for system stabilizability (i.e., all unstable modes are controllable). +## Returns 1 if the system is stabilizable, 0 if the system is not stabilizable, -1 +## if the system has non stabilizable modes at the imaginary axis (unit circle for +## discrete-time systems. +## +## Test for stabilizability is performed via Hautus Lemma. If +## @iftex +## @tex +## @var{dflg}$\neq$0 +## @end tex +## @end iftex +## @ifinfo +## @var{dflg}!=0 +## @end ifinfo +## assume that discrete-time matrices (a,b) are supplied. +## @seealso{size, rows, columns, length, ismatrix, isscalar, isvector, is_observable, is_stabilizable, is_detectable} +## @end deftypefn + +## Author: A. S. Hodel <a.s...@en...> +## Created: August 1993 +## Updated by A. S. Hodel (sc...@en...) Aubust, 1995 to use krylovb +## Updated by John Ingram (in...@en...) July, 1996 to accept systems + +## FIXME: where has the version which uses krylovb gone? +## Adapted-By: Lukas Reichlin <luk...@gm...> +## Date: October 2009 +## Version: 0.1 + +function retval = isstabilizable (a, b = [], tol = [], dflg = 0) + + if (nargin < 1) + print_usage (); + elseif (isa (a, "lti")) # system passed + if (nargin == 2) + tol = b; # get tolerance + elseif (nargin > 2) + print_usage (); + endif + disc = isdt(a); + [a, b] = ssdata (a); + else # a,b arguments sent directly + if (nargin > 4 || nargin == 1) + print_usage (); + endif + disc = dflg; + endif + + if (isempty (tol)) + tol = 200 * eps; + endif + + ## Checking dimensions + n = issquare (a); + [nr, m] = size (b); + + if (! n) + error ("isstabilizable: a must be square"); + endif + + if (nr != n) + error ("isstabilizable: (a,b) not conformal"); + endif + + ## Computing the eigenvalue of A + L = eig (a); + retval = 1; + specflag = 0; + + for k = 1 : n + if (! disc) + ## Continuous time case + rL = real (L(k)); + if (rL >= 0) + H = [eye(n)*L(k)-a, b]; + f = (rank (H, tol) == n); + if (f == 0) + retval = 0; + if (rL == 0) + specflag = 1; + endif + endif + endif + else + ## Discrete time case + rL = abs (L(k)); + if (rL >= 1) + H = [eye(n)*L(k)-a, b]; + f = (rank (H, tol) == n); + if (f == 0) + retval = 0; + if (rL == 1) + specflag = 1; + endif + endif + endif + endif + endfor + + if (specflag == 1) + ## This means that the system has uncontrollable modes at the imaginary axis + ## (or at the unit circle for discrete time systems) + retval = -1; + endif + +endfunction This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <par...@us...> - 2009-11-22 19:36:22
|
Revision: 6508 http://octave.svn.sourceforge.net/octave/?rev=6508&view=rev Author: paramaniac Date: 2009-11-22 19:36:08 +0000 (Sun, 22 Nov 2009) Log Message: ----------- control-oo: batch commit Modified Paths: -------------- trunk/octave-forge/extra/control-oo/INDEX trunk/octave-forge/extra/control-oo/inst/control/care.m trunk/octave-forge/extra/control-oo/inst/control/gram.m Added Paths: ----------- trunk/octave-forge/extra/control-oo/inst/control/estim.m trunk/octave-forge/extra/control-oo/inst/control/kalman.m Modified: trunk/octave-forge/extra/control-oo/INDEX =================================================================== --- trunk/octave-forge/extra/control-oo/INDEX 2009-11-22 12:57:05 UTC (rev 6507) +++ trunk/octave-forge/extra/control-oo/INDEX 2009-11-22 19:36:08 UTC (rev 6508) @@ -44,9 +44,11 @@ minreal sminreal Compensator Design + estim place LQR/LQG Design dlqr + kalman lqr Controller Synthesis State-Space Models Modified: trunk/octave-forge/extra/control-oo/inst/control/care.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/control/care.m 2009-11-22 12:57:05 UTC (rev 6507) +++ trunk/octave-forge/extra/control-oo/inst/control/care.m 2009-11-22 19:36:08 UTC (rev 6508) @@ -63,7 +63,7 @@ [n2, m2] = size (s); if (n2 != n || m2 != m) - error ("cs (%dx%d) must be identically dimensioned with b (%dx%d)", + error ("care: s (%dx%d) must be identically dimensioned with b (%dx%d)", n2, m2, n, m); endif Added: trunk/octave-forge/extra/control-oo/inst/control/estim.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/control/estim.m (rev 0) +++ trunk/octave-forge/extra/control-oo/inst/control/estim.m 2009-11-22 19:36:08 UTC (rev 6508) @@ -0,0 +1,57 @@ +## Copyright (C) 2009 Lukas F. Reichlin +## +## This file is part of LTI Syncope. +## +## LTI Syncope 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. +## +## LTI Syncope 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, see <http://www.gnu.org/licenses/>. + +## -*- texinfo -*- + +## Author: Lukas Reichlin <luk...@gm...> +## Created: November 2009 +## Version: 0.1 + +function est = estim (sys, l, sensors = [], known = []) + + if (nargin < 2 || nargin > 4) + print_usage (); + endif + + if (! isa (sys, "lti")) + error ("estim: first argument must be a LTI system"); + endif + + [a, b, c, d, tsam] = ssdata (sys); + + if (isempty (sensors)) + sensors = 1 : rows (c); + endif + + m = length (known); + n = rows (a); + p = length (sensors); + + b = b(:, known); + c = c(sensors, :); + d = d(sensors, known); + + f = a - l*c; + g = [b - l*d, l]; + h = [c; eye(n)]; + j = [d, zeros(p, p); zeros(n, m), zeros(n, p)]; + + est = ss (f, g, h, j, tsam); + + ## TODO: inname, stname, outname + +endfunction \ No newline at end of file Modified: trunk/octave-forge/extra/control-oo/inst/control/gram.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/control/gram.m 2009-11-22 12:57:05 UTC (rev 6507) +++ trunk/octave-forge/extra/control-oo/inst/control/gram.m 2009-11-22 19:36:08 UTC (rev 6508) @@ -49,13 +49,12 @@ error ("gram: first argument must be a LTI model"); endif - if (strcmp (argin2, "c")) - [a, b] = ssdata (argin1); - elseif (strcmp (argin2, "o")) - [a, b, c] = ssdata (argin1); + [a, b, c] = ssdata (sys); + + if (strcmp (argin2, "o")) a = a'; b = c'; - else + elseif (! strcmp (argin2, "c")) print_usage (); endif else # the function was called as "gram (a, b)" Added: trunk/octave-forge/extra/control-oo/inst/control/kalman.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/control/kalman.m (rev 0) +++ trunk/octave-forge/extra/control-oo/inst/control/kalman.m 2009-11-22 19:36:08 UTC (rev 6508) @@ -0,0 +1,54 @@ +## Copyright (C) 2009 Lukas F. Reichlin +## +## This file is part of LTI Syncope. +## +## LTI Syncope 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. +## +## LTI Syncope 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, see <http://www.gnu.org/licenses/>. + +## -*- texinfo -*- + +## Author: Lukas Reichlin <luk...@gm...> +## Created: November 2009 +## Version: 0.1 + +function [est, g, x] = kalman (sys, q, r, s = []) + + ## TODO: complex case (sensors, known, type "current" or "delayed" for discrete systems) + + if (nargin < 3 || nargin > 4) + print_usage (); + endif + + if (! isa (sys, "lti")) + print_usage (); + endif + + [a, b, c, d, tsam] = ssdata (sys); + + if (isempty (s)) + bs = []; + else + bs = b*s; + endif + + if (tsam > 0) + [x, l, g] = dare (a', c', b*q*b', r, bs); + else + [x, l, g] = care (a', c', b*q*b', r, bs); + endif + + g = g'; + + est = estim (sys, g); + +endfunction \ No newline at end of file This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <par...@us...> - 2009-11-26 19:46:38
|
Revision: 6536 http://octave.svn.sourceforge.net/octave/?rev=6536&view=rev Author: paramaniac Date: 2009-11-26 19:46:14 +0000 (Thu, 26 Nov 2009) Log Message: ----------- control-oo: add SLICOT routine AB08ND to compute transmission zeros of state-space models Modified Paths: -------------- trunk/octave-forge/extra/control-oo/inst/@ss/__zero__.m Added Paths: ----------- trunk/octave-forge/extra/control-oo/src/ trunk/octave-forge/extra/control-oo/src/AB08ND.f trunk/octave-forge/extra/control-oo/src/AB08NX.f trunk/octave-forge/extra/control-oo/src/MB03OY.f trunk/octave-forge/extra/control-oo/src/MB03PY.f trunk/octave-forge/extra/control-oo/src/TB01ID.f trunk/octave-forge/extra/control-oo/src/readme trunk/octave-forge/extra/control-oo/src/slab08nd.cc Modified: trunk/octave-forge/extra/control-oo/inst/@ss/__zero__.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/@ss/__zero__.m 2009-11-26 16:46:32 UTC (rev 6535) +++ trunk/octave-forge/extra/control-oo/inst/@ss/__zero__.m 2009-11-26 19:46:14 UTC (rev 6536) @@ -17,17 +17,28 @@ ## -*- texinfo -*- ## Transmission zeros of SS object. +## Uses SLICOT AB08ND by courtesy of NICONET e.V. +## <http://www.slicot.org> ## Author: Lukas Reichlin <luk...@gm...> ## Created: October 2009 ## Version: 0.1 -## TODO: Use Fortran code from Slicot - function [zer, gain] = __zero__ (sys) - warning ("ss: zero: subroutine tzero is buggy, use results with caution"); + [alphar, alphai, beta] = slab08nd (sys.a, sys.b, sys.c, sys.d); - [zer, gain] = __tzero__ (sys.a, sys.b, sys.c, sys.d); + zer = (alphar + i*alphai) ./ beta; + lz = length (zer); + n = rows (sys.a); + m = columns (sys.b); + p = rows (sys.c); + + if (lz == n) + gain = sys.d; + else + gain = sys.c * (sys.a^(n-1-lz)) * sys.b; + endif + endfunction \ No newline at end of file Added: trunk/octave-forge/extra/control-oo/src/AB08ND.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/AB08ND.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/AB08ND.f 2009-11-26 19:46:14 UTC (rev 6536) @@ -0,0 +1,568 @@ + SUBROUTINE AB08ND( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ NU, RANK, DINFZ, NKROR, NKROL, INFZ, KRONR, + $ KRONL, AF, LDAF, BF, LDBF, TOL, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To construct for a linear multivariable system described by a +C state-space model (A,B,C,D) a regular pencil (A - lambda*B ) which +C f f +C has the invariant zeros of the system as generalized eigenvalues. +C The routine also computes the orders of the infinite zeros and the +C right and left Kronecker indices of the system (A,B,C,D). +C +C ARGUMENTS +C +C Mode Parameters +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to balance the compound +C matrix (see METHOD) as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of state variables, i.e., the order of the +C matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state dynamics matrix A of the system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B of the system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C of the system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct transmission matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NU (output) INTEGER +C The number of (finite) invariant zeros. +C +C RANK (output) INTEGER +C The normal rank of the transfer function matrix. +C +C DINFZ (output) INTEGER +C The maximum degree of infinite elementary divisors. +C +C NKROR (output) INTEGER +C The number of right Kronecker indices. +C +C NKROL (output) INTEGER +C The number of left Kronecker indices. +C +C INFZ (output) INTEGER array, dimension (N) +C The leading DINFZ elements of INFZ contain information +C on the infinite elementary divisors as follows: +C the system has INFZ(i) infinite elementary divisors +C of degree i, where i = 1,2,...,DINFZ. +C +C KRONR (output) INTEGER array, dimension (MAX(N,M)+1) +C The leading NKROR elements of this array contain the +C right Kronecker (column) indices. +C +C KRONL (output) INTEGER array, dimension (MAX(N,P)+1) +C The leading NKROL elements of this array contain the +C left Kronecker (row) indices. +C +C AF (output) DOUBLE PRECISION array, dimension +C (LDAF,N+MIN(P,M)) +C The leading NU-by-NU part of this array contains the +C coefficient matrix A of the reduced pencil. The remainder +C f +C of the leading (N+M)-by-(N+MIN(P,M)) part is used as +C internal workspace. +C +C LDAF INTEGER +C The leading dimension of array AF. LDAF >= MAX(1,N+M). +C +C BF (output) DOUBLE PRECISION array, dimension (LDBF,N+M) +C The leading NU-by-NU part of this array contains the +C coefficient matrix B of the reduced pencil. The +C f +C remainder of the leading (N+P)-by-(N+M) part is used as +C internal workspace. +C +C LDBF INTEGER +C The leading dimension of array BF. LDBF >= MAX(1,N+P). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS +C then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (MAX(M,P)) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M), +C MIN(M,N) + MAX(3*M-1,N+M) ). +C An upper bound is MAX(s,N) + MAX(3*s-1,N+s), with +C s = MAX(M,P). +C For optimum performance LDWORK should be larger. +C +C If LDWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C DWORK array, returns this value as the first entry of +C the DWORK array, and no error message related to LDWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine extracts from the system matrix of a state-space +C system (A,B,C,D) a regular pencil A - lambda*B which has the +C f f +C invariant zeros of the system as generalized eigenvalues as +C follows: +C +C (a) construct the (N+P)-by-(N+M) compound matrix (B A); +C (D C) +C +C (b) reduce the above system to one with the same invariant +C zeros and with D of full row rank; +C +C (c) pertranspose the system; +C +C (d) reduce the system to one with the same invariant zeros and +C with D square invertible; +C +C (e) perform a unitary transformation on the columns of +C (A - lambda*I B) in order to reduce it to +C ( C D) +C +C (A - lambda*B X) +C ( f f ), with Y and B square invertible; +C ( 0 Y) f +C +C (f) compute the right and left Kronecker indices of the system +C (A,B,C,D), which together with the orders of the infinite +C zeros (determined by steps (a) - (e)) constitute the +C complete set of structural invariants under strict +C equivalence transformations of a linear system. +C +C REFERENCES +C +C [1] Svaricek, F. +C Computation of the Structural Invariants of Linear +C Multivariable Systems with an Extended Version of +C the Program ZEROS. +C System & Control Letters, 6, pp. 261-266, 1985. +C +C [2] Emami-Naeini, A. and Van Dooren, P. +C Computation of Zeros of Linear Multivariable Systems. +C Automatica, 18, pp. 415-430, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable (see [2] and [1]). +C +C FURTHER COMMENTS +C +C In order to compute the invariant zeros of the system explicitly, +C a call to this routine may be followed by a call to the LAPACK +C Library routine DGGEV with A = A , B = B and N = NU. +C f f +C If RANK = 0, the routine DGEEV can be used (since B = I). +C f +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C Supersedes Release 2.0 routine AB08BD by F. Svaricek. +C +C REVISIONS +C +C Oct. 1997, Feb. 1998, Dec. 2003, March 2004, Jan. 2009, Mar. 2009, +C Apr. 2009. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, multivariable +C system, orthogonal transformation, structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL + INTEGER DINFZ, INFO, LDA, LDAF, LDB, LDBF, LDC, LDD, + $ LDWORK, M, N, NKROL, NKROR, NU, P, RANK + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER INFZ(*), IWORK(*), KRONL(*), KRONR(*) + DOUBLE PRECISION A(LDA,*), AF(LDAF,*), B(LDB,*), BF(LDBF,*), + $ C(LDC,*), D(LDD,*), DWORK(*) +C .. Local Scalars .. + LOGICAL LEQUIL, LQUERY + INTEGER I, I1, II, J, MM, MNU, MU, NB, NINFZ, NN, NU1, + $ NUMU, NUMU1, PP, RO, SIGMA, WRKOPT + DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL AB08NX, DCOPY, DLACPY, DLASET, DORMRZ, DTZRZF, + $ TB01ID, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + LEQUIL = LSAME( EQUIL, 'S' ) + LQUERY = ( LDWORK.EQ.-1 ) +C +C Test the input scalar arguments. +C + IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDAF.LT.MAX( 1, N + M ) ) THEN + INFO = -22 + ELSE IF( LDBF.LT.MAX( 1, N + P ) ) THEN + INFO = -24 + ELSE + II = MIN( P, M ) + I = MAX( II + MAX( 3*M - 1, N ), + $ MIN( P, N ) + MAX( 3*P - 1, N+P, N+M ), + $ MIN( M, N ) + MAX( 3*M - 1, N+M ), 1 ) + IF( LQUERY ) THEN + SVLMAX = ZERO + NINFZ = 0 + CALL AB08NX( N, M, P, P, 0, SVLMAX, BF, LDBF, NINFZ, INFZ, + $ KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, -1, + $ INFO ) + WRKOPT = MAX( I, INT( DWORK(1) ) ) + CALL AB08NX( N, II, M, M-II, II, SVLMAX, AF, LDAF, NINFZ, + $ INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, + $ -1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + NB = ILAENV( 1, 'DGERQF', ' ', II, N+II, -1, -1 ) + WRKOPT = MAX( WRKOPT, II + II*NB ) + NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RT', N, N+II, II, -1 ) ) + WRKOPT = MAX( WRKOPT, II + N*NB ) + ELSE IF( LDWORK.LT.I ) THEN + INFO = -28 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB08ND', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + DWORK(1) = WRKOPT + RETURN + END IF +C + DINFZ = 0 + NKROL = 0 + NKROR = 0 +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + IF ( MIN( M, P ).EQ.0 ) THEN + NU = 0 + RANK = 0 + DWORK(1) = ONE + RETURN + END IF + END IF +C + MM = M + NN = N + PP = P +C + DO 20 I = 1, N + INFZ(I) = 0 + 20 CONTINUE +C + IF ( M.GT.0 ) THEN + DO 40 I = 1, N + 1 + KRONR(I) = 0 + 40 CONTINUE + END IF +C + IF ( P.GT.0 ) THEN + DO 60 I = 1, N + 1 + KRONL(I) = 0 + 60 CONTINUE + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + WRKOPT = 1 +C +C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). +C ( D C ) +C + CALL DLACPY( 'Full', NN, MM, B, LDB, BF, LDBF ) + IF ( PP.GT.0 ) + $ CALL DLACPY( 'Full', PP, MM, D, LDD, BF(1+NN,1), LDBF ) + IF ( NN.GT.0 ) THEN + CALL DLACPY( 'Full', NN, NN, A, LDA, BF(1,1+MM), LDBF ) + IF ( PP.GT.0 ) + $ CALL DLACPY( 'Full', PP, NN, C, LDC, BF(1+NN,1+MM), LDBF ) + END IF +C +C If required, balance the compound matrix (default MAXRED). +C Workspace: need N. +C + IF ( LEQUIL .AND. NN.GT.0 .AND. PP.GT.0 ) THEN + MAXRED = ZERO + CALL TB01ID( 'A', NN, MM, PP, MAXRED, BF(1,1+MM), LDBF, BF, + $ LDBF, BF(1+NN,1+MM), LDBF, DWORK, INFO ) + WRKOPT = N + END IF +C +C If required, set tolerance. +C + THRESH = SQRT( DBLE( (N + P)*(N + M) ) )*DLAMCH( 'Precision' ) + TOLER = TOL + IF ( TOLER.LT.THRESH ) TOLER = THRESH + SVLMAX = DLANGE( 'Frobenius', NN+PP, NN+MM, BF, LDBF, DWORK ) +C +C Reduce this system to one with the same invariant zeros and with +C D upper triangular of full row rank MU (the normal rank of the +C original system). +C Workspace: need MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M) ); +C prefer larger. +C + RO = PP + SIGMA = 0 + NINFZ = 0 + CALL AB08NX( NN, MM, PP, RO, SIGMA, SVLMAX, BF, LDBF, NINFZ, INFZ, + $ KRONL, MU, NU, NKROL, TOLER, IWORK, DWORK, LDWORK, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + RANK = MU +C +C Pertranspose the system. +C + NUMU = NU + MU + IF ( NUMU.NE.0 ) THEN + MNU = MM + NU + NUMU1 = NUMU + 1 +C + DO 80 I = 1, NUMU + CALL DCOPY( MNU, BF(I,1), LDBF, AF(1,NUMU1-I), -1 ) + 80 CONTINUE +C + IF ( MU.NE.MM ) THEN +C +C Here MU < MM and MM > 0 (since MM = 0 implies MU = 0 = MM). +C + PP = MM + NN = NU + MM = MU +C +C Reduce the system to one with the same invariant zeros and +C with D square invertible. +C Workspace: need MAX( 1, MU + MAX(3*MU-1,N), +C MIN(M,N) + MAX(3*M-1,N+M) ); +C prefer larger. Note that MU <= MIN(P,M). +C + RO = PP - MM + SIGMA = MM + CALL AB08NX( NN, MM, PP, RO, SIGMA, SVLMAX, AF, LDAF, NINFZ, + $ INFZ, KRONR, MU, NU, NKROR, TOLER, IWORK, + $ DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + END IF +C + IF ( NU.NE.0 ) THEN +C +C Perform a unitary transformation on the columns of +C ( B A-lambda*I ) +C ( D C ) +C in order to reduce it to +C ( X AF-lambda*BF ) +C ( Y 0 ) +C with Y and BF square invertible. +C + CALL DLASET( 'Full', NU, MU, ZERO, ZERO, BF, LDBF ) + CALL DLASET( 'Full', NU, NU, ZERO, ONE, BF(1,MU+1), LDBF ) +C + IF ( RANK.NE.0 ) THEN + NU1 = NU + 1 + I1 = NU + MU +C +C Workspace: need 2*MIN(M,P); +C prefer MIN(M,P) + MIN(M,P)*NB. +C + CALL DTZRZF( MU, I1, AF(NU1,1), LDAF, DWORK, DWORK(MU+1), + $ LDWORK-MU, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(MU+1) ) + MU ) +C +C Workspace: need MIN(M,P) + N; +C prefer MIN(M,P) + N*NB. +C + CALL DORMRZ( 'Right', 'Transpose', NU, I1, MU, NU, + $ AF(NU1,1), LDAF, DWORK, AF, LDAF, + $ DWORK(MU+1), LDWORK-MU, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(MU+1) ) + MU ) +C + CALL DORMRZ( 'Right', 'Transpose', NU, I1, MU, NU, + $ AF(NU1,1), LDAF, DWORK, BF, LDBF, + $ DWORK(MU+1), LDWORK-MU, INFO ) +C + END IF +C +C Move AF and BF in the first columns. This assumes that +C DLACPY moves column by column. +C + CALL DLACPY( 'Full', NU, NU, AF(1,MU+1), LDAF, AF, LDAF ) + IF ( RANK.NE.0 ) + $ CALL DLACPY( 'Full', NU, NU, BF(1,MU+1), LDBF, BF, LDBF ) +C + END IF + END IF +C +C Set right Kronecker indices (column indices). +C + IF ( NKROR.GT.0 ) THEN + J = 1 +C + DO 120 I = 1, N + 1 +C + DO 100 II = J, J + KRONR(I) - 1 + IWORK(II) = I - 1 + 100 CONTINUE +C + J = J + KRONR(I) + KRONR(I) = 0 + 120 CONTINUE +C + NKROR = J - 1 +C + DO 140 I = 1, NKROR + KRONR(I) = IWORK(I) + 140 CONTINUE +C + END IF +C +C Set left Kronecker indices (row indices). +C + IF ( NKROL.GT.0 ) THEN + J = 1 +C + DO 180 I = 1, N + 1 +C + DO 160 II = J, J + KRONL(I) - 1 + IWORK(II) = I - 1 + 160 CONTINUE +C + J = J + KRONL(I) + KRONL(I) = 0 + 180 CONTINUE +C + NKROL = J - 1 +C + DO 200 I = 1, NKROL + KRONL(I) = IWORK(I) + 200 CONTINUE +C + END IF +C + IF ( N.GT.0 ) THEN + DINFZ = N +C + 220 CONTINUE + IF ( INFZ(DINFZ).EQ.0 ) THEN + DINFZ = DINFZ - 1 + IF ( DINFZ.GT.0 ) + $ GO TO 220 + END IF + END IF +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of AB08ND *** + END Added: trunk/octave-forge/extra/control-oo/src/AB08NX.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/AB08NX.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/AB08NX.f 2009-11-26 19:46:14 UTC (rev 6536) @@ -0,0 +1,446 @@ + SUBROUTINE AB08NX( N, M, P, RO, SIGMA, SVLMAX, ABCD, LDABCD, + $ NINFZ, INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To extract from the (N+P)-by-(M+N) system +C ( B A ) +C ( D C ) +C an (NU+MU)-by-(M+NU) "reduced" system +C ( B' A') +C ( D' C') +C having the same transmission zeros but with D' of full row rank. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of state variables. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C RO (input/output) INTEGER +C On entry, +C = P for the original system; +C = MAX(P-M, 0) for the pertransposed system. +C On exit, RO contains the last computed rank. +C +C SIGMA (input/output) INTEGER +C On entry, +C = 0 for the original system; +C = M for the pertransposed system. +C On exit, SIGMA contains the last computed value sigma in +C the algorithm. +C +C SVLMAX (input) DOUBLE PRECISION +C During each reduction step, the rank-revealing QR +C factorization of a matrix stops when the estimated minimum +C singular value is smaller than TOL * MAX(SVLMAX,EMSV), +C where EMSV is the estimated maximum singular value. +C SVLMAX >= 0. +C +C ABCD (input/output) DOUBLE PRECISION array, dimension +C (LDABCD,M+N) +C On entry, the leading (N+P)-by-(M+N) part of this array +C must contain the compound input matrix of the system. +C On exit, the leading (NU+MU)-by-(M+NU) part of this array +C contains the reduced compound input matrix of the system. +C +C LDABCD INTEGER +C The leading dimension of array ABCD. +C LDABCD >= MAX(1,N+P). +C +C NINFZ (input/output) INTEGER +C On entry, the currently computed number of infinite zeros. +C It should be initialized to zero on the first call. +C NINFZ >= 0. +C On exit, the number of infinite zeros. +C +C INFZ (input/output) INTEGER array, dimension (N) +C On entry, INFZ(i) must contain the current number of +C infinite zeros of degree i, where i = 1,2,...,N, found in +C the previous call(s) of the routine. It should be +C initialized to zero on the first call. +C On exit, INFZ(i) contains the number of infinite zeros of +C degree i, where i = 1,2,...,N. +C +C KRONL (input/output) INTEGER array, dimension (N+1) +C On entry, this array must contain the currently computed +C left Kronecker (row) indices found in the previous call(s) +C of the routine. It should be initialized to zero on the +C first call. +C On exit, the leading NKROL elements of this array contain +C the left Kronecker (row) indices. +C +C MU (output) INTEGER +C The normal rank of the transfer function matrix of the +C original system. +C +C NU (output) INTEGER +C The dimension of the reduced system matrix and the number +C of (finite) invariant zeros if D' is invertible. +C +C NKROL (output) INTEGER +C The number of left Kronecker indices. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C NOTE that when SVLMAX > 0, the estimated ranks could be +C less than those defined above (see SVLMAX). +C +C Workspace +C +C IWORK INTEGER array, dimension (MAX(M,P)) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M) ). +C For optimum performance LDWORK should be larger. +C +C If LDWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C DWORK array, returns this value as the first entry of +C the DWORK array, and no error message related to LDWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Svaricek, F. +C Computation of the Structural Invariants of Linear +C Multivariable Systems with an Extended Version of +C the Program ZEROS. +C System & Control Letters, 6, pp. 261-266, 1985. +C +C [2] Emami-Naeini, A. and Van Dooren, P. +C Computation of Zeros of Linear Multivariable Systems. +C Automatica, 18, pp. 415-430, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C Supersedes Release 2.0 routine AB08BZ by F. Svaricek. +C +C REVISIONS +C +C V. Sima, Oct. 1997; Feb. 1998, Jan. 2009, Apr. 2009. +C A. Varga, May 1999; May 2001. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, multivariable +C system, orthogonal transformation, structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDABCD, LDWORK, M, MU, N, NINFZ, NKROL, + $ NU, P, RO, SIGMA + DOUBLE PRECISION SVLMAX, TOL +C .. Array Arguments .. + INTEGER INFZ(*), IWORK(*), KRONL(*) + DOUBLE PRECISION ABCD(LDABCD,*), DWORK(*) +C .. Local Scalars .. + LOGICAL LQUERY + INTEGER I1, IK, IROW, ITAU, IZ, JWORK, MM1, MNTAU, MNU, + $ MPM, NB, NP, RANK, RO1, TAU, WRKOPT + DOUBLE PRECISION T +C .. Local Arrays .. + DOUBLE PRECISION SVAL(3) +C .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +C .. External Subroutines .. + EXTERNAL DLAPMT, DLARFG, DLASET, DLATZM, DORMQR, DORMRQ, + $ MB03OY, MB03PY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + NP = N + P + MPM = MIN( P, M ) + INFO = 0 + LQUERY = ( LDWORK.EQ.-1 ) +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( RO.NE.P .AND. RO.NE.MAX( P-M, 0 ) ) THEN + INFO = -4 + ELSE IF( SIGMA.NE.0 .AND. SIGMA.NE.M ) THEN + INFO = -5 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDABCD.LT.MAX( 1, NP ) ) THEN + INFO = -8 + ELSE IF( NINFZ.LT.0 ) THEN + INFO = -9 + ELSE + JWORK = MAX( 1, MPM + MAX( 3*M - 1, N ), + $ MIN( P, N ) + MAX( 3*P - 1, NP, N+M ) ) + IF( LQUERY ) THEN + IF( M.GT.0 ) THEN + NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LT', P, N, MPM, + $ -1 ) ) + WRKOPT = MAX( JWORK, MPM + MAX( 1, N )*NB ) + ELSE + WRKOPT = JWORK + END IF + NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RT', NP, N, MIN( P, N ), + $ -1 ) ) + WRKOPT = MAX( WRKOPT, MIN( P, N ) + MAX( 1, NP )*NB ) + NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'LN', N, M+N, + $ MIN( P, N ), -1 ) ) + WRKOPT = MAX( WRKOPT, MIN( P, N ) + MAX( 1, M+N )*NB ) + ELSE IF( LDWORK.LT.JWORK ) THEN + INFO = -18 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB08NX', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + DWORK(1) = WRKOPT + RETURN + END IF +C + MU = P + NU = N +C + IZ = 0 + IK = 1 + MM1 = M + 1 + ITAU = 1 + NKROL = 0 + WRKOPT = 1 +C +C Main reduction loop: +C +C M NU M NU +C NU [ B A ] NU [ B A ] +C MU [ D C ] --> SIGMA [ RD C1 ] (SIGMA = rank(D) = +C TAU [ 0 C2 ] row size of RD) +C +C M NU-RO RO +C NU-RO [ B1 A11 A12 ] +C --> RO [ B2 A21 A22 ] (RO = rank(C2) = +C SIGMA [ RD C11 C12 ] col size of LC) +C TAU [ 0 0 LC ] +C +C M NU-RO +C NU-RO [ B1 A11 ] NU := NU - RO +C [----------] MU := RO + SIGMA +C --> RO [ B2 A21 ] D := [B2;RD] +C SIGMA [ RD C11 ] C := [A21;C11] +C + 20 IF ( MU.EQ.0 ) + $ GO TO 80 +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + RO1 = RO + MNU = M + NU + IF ( M.GT.0 ) THEN + IF ( SIGMA.NE.0 ) THEN + IROW = NU + 1 +C +C Compress rows of D. First exploit triangular shape. +C Workspace: need M+N-1. +C + DO 40 I1 = 1, SIGMA + CALL DLARFG( RO+1, ABCD(IROW,I1), ABCD(IROW+1,I1), 1, T ) + CALL DLATZM( 'L', RO+1, MNU-I1, ABCD(IROW+1,I1), 1, T, + $ ABCD(IROW,I1+1), ABCD(IROW+1,I1+1), LDABCD, + $ DWORK ) + IROW = IROW + 1 + 40 CONTINUE + CALL DLASET( 'Lower', RO+SIGMA-1, SIGMA, ZERO, ZERO, + $ ABCD(NU+2,1), LDABCD ) + END IF +C +C Continue with Householder with column pivoting. +C +C The rank of D is the number of (estimated) singular values +C that are greater than TOL * MAX(SVLMAX,EMSV). This number +C includes the singular values of the first SIGMA columns. +C Integer workspace: need M; +C Workspace: need min(RO1,M) + 3*M - 1. RO1 <= P. +C + IF ( SIGMA.LT.M ) THEN + JWORK = ITAU + MIN( RO1, M ) + I1 = SIGMA + 1 + IROW = NU + I1 + CALL MB03OY( RO1, M-SIGMA, ABCD(IROW,I1), LDABCD, TOL, + $ SVLMAX, RANK, SVAL, IWORK, DWORK(ITAU), + $ DWORK(JWORK), INFO ) + WRKOPT = MAX( WRKOPT, JWORK + 3*M - 2 ) +C +C Apply the column permutations to matrices B and part of D. +C + CALL DLAPMT( .TRUE., NU+SIGMA, M-SIGMA, ABCD(1,I1), LDABCD, + $ IWORK ) +C + IF ( RANK.GT.0 ) THEN +C +C Apply the Householder transformations to the submatrix C. +C Workspace: need min(RO1,M) + NU; +C prefer min(RO1,M) + NU*NB. +C + CALL DORMQR( 'Left', 'Transpose', RO1, NU, RANK, + $ ABCD(IROW,I1), LDABCD, DWORK(ITAU), + $ ABCD(IROW,MM1), LDABCD, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF ( RO1.GT.1 ) + $ CALL DLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO, + $ ZERO, ABCD(IROW+1,I1), LDABCD ) + RO1 = RO1 - RANK + END IF + END IF + END IF +C + TAU = RO1 + SIGMA = MU - TAU +C +C Determination of the orders of the infinite zeros. +C + IF ( IZ.GT.0 ) THEN + INFZ(IZ) = INFZ(IZ) + RO - TAU + NINFZ = NINFZ + IZ*( RO - TAU ) + END IF + IF ( RO1.EQ.0 ) + $ GO TO 80 + IZ = IZ + 1 +C + IF ( NU.LE.0 ) THEN + MU = SIGMA + NU = 0 + RO = 0 + ELSE +C +C Compress the columns of C2 using RQ factorization with row +C pivoting, P * C2 = R * Q. +C + I1 = NU + SIGMA + 1 + MNTAU = MIN( TAU, NU ) + JWORK = ITAU + MNTAU +C +C The rank of C2 is the number of (estimated) singular values +C greater than TOL * MAX(SVLMAX,EMSV). +C Integer Workspace: need TAU; +C Workspace: need min(TAU,NU) + 3*TAU - 1. +C + CALL MB03PY( TAU, NU, ABCD(I1,MM1), LDABCD, TOL, SVLMAX, RANK, + $ SVAL, IWORK, DWORK(ITAU), DWORK(JWORK), INFO ) + WRKOPT = MAX( WRKOPT, JWORK + 3*TAU - 1 ) + IF ( RANK.GT.0 ) THEN + IROW = I1 + TAU - RANK +C +C Apply Q' to the first NU columns of [A; C1] from the right. +C Workspace: need min(TAU,NU) + NU + SIGMA; SIGMA <= P; +C prefer min(TAU,NU) + (NU + SIGMA)*NB. +C + CALL DORMRQ( 'Right', 'Transpose', I1-1, NU, RANK, + $ ABCD(IROW,MM1), LDABCD, DWORK(MNTAU-RANK+1), + $ ABCD(1,MM1), LDABCD, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Apply Q to the first NU rows and M + NU columns of [ B A ] +C from the left. +C Workspace: need min(TAU,NU) + M + NU; +C prefer min(TAU,NU) + (M + NU)*NB. +C + CALL DORMRQ( 'Left', 'NoTranspose', NU, MNU, RANK, + $ ABCD(IROW,MM1), LDABCD, DWORK(MNTAU-RANK+1), + $ ABCD, LDABCD, DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + CALL DLASET( 'Full', RANK, NU-RANK, ZERO, ZERO, + $ ABCD(IROW,MM1), LDABCD ) + IF ( RANK.GT.1 ) + $ CALL DLASET( 'Lower', RANK-1, RANK-1, ZERO, ZERO, + $ ABCD(IROW+1,MM1+NU-RANK), LDABCD ) + END IF +C + RO = RANK + END IF +C +C Determine the left Kronecker indices (row indices). +C + KRONL(IK) = KRONL(IK) + TAU - RO + NKROL = NKROL + KRONL(IK) + IK = IK + 1 +C +C C and D are updated to [A21 ; C11] and [B2 ; RD]. +C + NU = NU - RO + MU = SIGMA + RO + IF ( RO.NE.0 ) + $ GO TO 20 +C + 80 CONTINUE + DWORK(1) = WRKOPT + RETURN +C *** Last line of AB08NX *** + END Added: trunk/octave-forge/extra/control-oo/src/MB03OY.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/MB03OY.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/MB03OY.f 2009-11-26 19:46:14 UTC (rev 6536) @@ -0,0 +1,388 @@ + SUBROUTINE MB03OY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, + $ TAU, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To compute a rank-revealing QR factorization of a real general +C M-by-N matrix A, which may be rank-deficient, and estimate its +C effective rank using incremental condition estimation. +C +C The routine uses a truncated QR factorization with column pivoting +C [ R11 R12 ] +C A * P = Q * R, where R = [ ], +C [ 0 R22 ] +C with R11 defined as the largest leading upper triangular submatrix +C whose estimated condition number is less than 1/RCOND. The order +C of R11, RANK, is the effective rank of A. Condition estimation is +C performed during the QR factorization process. Matrix R22 is full +C (but of small norm), or empty. +C +C MB03OY does not perform any scaling of the matrix A. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C ( LDA, N ) +C On entry, the leading M-by-N part of this array must +C contain the given matrix A. +C On exit, the leading RANK-by-RANK upper triangular part +C of A contains the triangular factor R11, and the elements +C below the diagonal in the first RANK columns, with the +C array TAU, represent the orthogonal matrix Q as a product +C of RANK elementary reflectors. +C The remaining N-RANK columns contain the result of the +C QR factorization process used. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of A, which +C is defined as the order of the largest leading triangular +C submatrix R11 in the QR factorization with pivoting of A, +C whose estimated condition number is less than 1/RCOND. +C 0 <= RCOND <= 1. +C NOTE that when SVLMAX > 0, the estimated rank could be +C less than that defined above (see SVLMAX). +C +C SVLMAX (input) DOUBLE PRECISION +C If A is a submatrix of another matrix B, and the rank +C decision should be related to that matrix, then SVLMAX +C should be an estimate of the largest singular value of B +C (for instance, the Frobenius norm of B). If this is not +C the case, the input value SVLMAX = 0 should work. +C SVLMAX >= 0. +C +C RANK (output) INTEGER +C The effective (estimated) rank of A, i.e., the order of +C the submatrix R11. +C +C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) +C The estimates of some of the singular values of the +C triangular factor R: +C SVAL(1): largest singular value of R(1:RANK,1:RANK); +C SVAL(2): smallest singular value of R(1:RANK,1:RANK); +C SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1), +C if RANK < MIN( M, N ), or of R(1:RANK,1:RANK), +C otherwise. +C If the triangular factorization is a rank-revealing one +C (which will be the case if the leading columns were well- +C conditioned), then SVAL(1) will also be an estimate for +C the largest singular value of A, and SVAL(2) and SVAL(3) +C will be estimates for the RANK-th and (RANK+1)-st singular +C values of A, respectively. +C By examining these values, one can confirm that the rank +C is well defined with respect to the chosen value of RCOND. +C The ratio SVAL(1)/SVAL(2) is an estimate of the condition +C number of R(1:RANK,1:RANK). +C +C JPVT (output) INTEGER array, dimension ( N ) +C If JPVT(i) = k, then the i-th column of A*P was the k-th +C column of A. +C +C TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) +C The leading RANK elements of TAU contain the scalar +C factors of the elementary reflectors. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension ( 3*N-1 ) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes a truncated QR factorization with column +C pivoting of A, A * P = Q * R, with R defined above, and, +C during this process, finds the largest leading submatrix whose +C estimated condition number is less than 1/RCOND, taking the +C possible positive value of SVLMAX into account. This is performed +C using the LAPACK incremental condition estimation scheme and a +C slightly modified rank decision test. The factorization process +C stops when RANK has been determined. +C +C The matrix Q is represented as a product of elementary reflectors +C +C Q = H(1) H(2) . . . H(k), where k = rank <= min(m,n). +C +C Each H(i) has the form +C +C H = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in +C A(i+1:m,i), and tau in TAU(i). +C +C The matrix P is represented in jpvt as follows: If +C jpvt(j) = i +C then the jth column of P is the ith canonical unit vector. +C +C REFERENCES +C +C [1] Bischof, C.H. and P. Tang. +C Generalizing Incremental Condition Estimation. +C LAPACK Working Notes 32, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-132, +C May 1991. +C +C [2] Bischof, C.H. and P. Tang. +C Robust Incremental Condition Estimation. +C LAPACK Working Notes 33, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-133, +C May 1991. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2009. +C +C KEYWORDS +C +C Eigenvalue problem, matrix operations, orthogonal transformation, +C singular values. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ZERO, ONE, P05 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, P05 = 0.05D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, M, N, RANK + DOUBLE PRECISION RCOND, SVLMAX +C .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), DWORK( * ), SVAL( 3 ), TAU( * ) +C .. +C .. Local Scalars .. + INTEGER I, ISMAX, ISMIN, ITEMP, J, MN, PVT + DOUBLE PRECISION AII, C1, C2, S1, S2, SMAX, SMAXPR, SMIN, + $ SMINPR, TEMP, TEMP2 +C .. +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2, IDAMAX +C .. External Subroutines .. + EXTERNAL DLAIC1, DLARF, DLARFG, DSCAL, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN + INFO = -5 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -6 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03OY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + MN = MIN( M, N ) + IF( MN.EQ.0 ) THEN + RANK = 0 + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF +C + ISMIN = 1 + ISMAX = ISMIN + N +C +C Initialize partial column norms and pivoting vector. The first n +C elements of DWORK store the exact column norms. The already used +C leading part is then overwritten by the condition estimator. +C + DO 10 I = 1, N + DWORK( I ) = DNRM2( M, A( 1, I ), 1 ) + DWORK( N+I ) = DWORK( I ) + JPVT( I ) = I + 10 CONTINUE +C +C Compute factorization and determine RANK using incremental +C condition estimation. +C + RANK = 0 +C + 20 CONTINUE + IF( RANK.LT.MN ) THEN + I = RANK + 1 +C +C Determine ith pivot column and swap if necessary. +C + PVT = ( I-1 ) + IDAMAX( N-I+1, DWORK( I ), 1 ) +C + IF( PVT.NE.I ) THEN + CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( I ) + JPVT( I ) = ITEMP + DWORK( PVT ) = DWORK( I ) + DWORK( N+PVT ) = DWORK( N+I ) + END IF +C +C Save A(I,I) and generate elementary reflector H(i). +C + IF( I.LT.M ) THEN + AII = A( I, I ) + CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) ) + ELSE + TAU( M ) = ZERO + END IF +C + IF( RANK.EQ.0 ) THEN +C +C Initialize; exit if matrix is zero (RANK = 0). +C + SMAX = ABS( A( 1, 1 ) ) + IF ( SMAX.EQ.ZERO ) THEN + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF + SMIN = SMAX + SMAXPR = SMAX + SMINPR = SMIN + C1 = ONE + C2 = ONE + ELSE +C +C One step of incremental condition estimation. +C + CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, A( 1, I ), + $ A( I, I ), SMINPR, S1, C1 ) + CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, A( 1, I ), + $ A( I, I ), SMAXPR, S2, C2 ) + END IF +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN +C +C Continue factorization, as rank is at least RANK. +C + IF( I.LT.N ) THEN +C +C Apply H(i) to A(i:m,i+1:n) from the left. +C + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, + $ TAU( I ), A( I, I+1 ), LDA, + $ DWORK( 2*N+1 ) ) + A( I, I ) = AII + END IF +C +C Update partial column norms. +C + DO 30 J = I + 1, N + IF( DWORK( J ).NE.ZERO ) THEN + TEMP = ONE - + $ ( ABS( A( I, J ) ) / DWORK( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = ONE + P05*TEMP* + $ ( DWORK( J ) / DWORK( N+J ) )**2 + IF( TEMP2.EQ.ONE ) THEN + IF( M-I.GT.0 ) THEN + DWORK( J ) = DNRM2( M-I, A( I+1, J ), 1 ) + DWORK( N+J ) = DWORK( J ) + ELSE + DWORK( J ) = ZERO + DWORK( N+J ) = ZERO + END IF + ELSE + DWORK( J ) = DWORK( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE +C + DO 40 I = 1, RANK + DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) + DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) + 40 CONTINUE +C + DWORK( ISMIN+RANK ) = C1 + DWORK( ISMAX+RANK ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + GO TO 20 + END IF + END IF + END IF + END IF +C +C Restore the changed part of the (RANK+1)-th column and set SVAL. +C + IF ( RANK.LT.N ) THEN + IF ( I.LT.M ) THEN + CALL DSCAL( M-I, -A( I, I )*TAU( I ), A( I+1, I ), 1 ) + A( I, I ) = AII + END IF + END IF + IF ( RANK.EQ.0 ) THEN + SMIN = ZERO + SMINPR = ZERO + END IF + SVAL( 1 ) = SMAX + SVAL( 2 ) = SMIN + SVAL( 3 ) = SMINPR +C + RETURN +C *** Last line of MB03OY *** + END Added: trunk/octave-forge/extra/control-oo/src/MB03PY.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/MB03PY.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/MB03PY.f 2009-11-26 19:46:14 UTC (rev 6536) @@ -0,0 +1,392 @@ + SUBROUTINE MB03PY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, + $ TAU, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To compute a rank-revealing RQ factorization of a real general +C M-by-N matrix A, which may be rank-deficient, and estimate its +C effective rank using incremental condition estimation. +C +C The routine uses a truncated RQ factorization with row pivoting: +C [ R11 R12 ] +C P * A = R * Q, where R = [ ], +C [ 0 R22 ] +C with R22 defined as the largest trailing upper triangular +C submatrix whose estimated condition number is less than 1/RCOND. +C The order of R22, RANK, is the effective rank of A. Condition +C estimation is performed during the RQ factorization process. +C Matrix R11 is full (but of small norm), or empty. +C +C MB03PY does not perform any scaling of the matrix A. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C ( LDA, N ) +C On entry, the leading M-by-N part of this array must +C contain the given matrix A. +C On exit, the upper triangle of the subarray +C A(M-RANK+1:M,N-RANK+1:N) contains the RANK-by-RANK upper +C triangular matrix R22; the remaining elements in the last +C RANK rows, with the array TAU, represent the orthogonal +C matrix Q as a product of RANK elementary reflectors +C (see METHOD). The first M-RANK rows contain the result +C of the RQ factorization process used. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of A, which +C is defined as the order of the largest trailing triangular +C submatrix R22 in the RQ factorization with pivoting of A, +C whose estimated condition number is less than 1/RCOND. +C 0 <= RCOND <= 1. +C NOTE that when SVLMAX > 0, the estimated rank could be +C less than that defined above (see SVLMAX). +C +C SVLMAX (input) DOUBLE PRECISION +C If A is a submatrix of another matrix B, and the rank +C decision should be related to that matrix, then SVLMAX +C should be an estimate of the largest singular value of B +C (for instance, the Frobenius norm of B). If this is not +C the case, the input value SVLMAX = 0 should work. +C SVLMAX >= 0. +C +C RANK (output) INTEGER +C The effective (estimated) rank of A, i.e., the order of +C the submatrix R22. +C +C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) +C The estimates of some of the singular values of the +C triangular factor R: +C SVAL(1): largest singular value of +C R(M-RANK+1:M,N-RANK+1:N); +C SVAL(2): smallest singular value of +C R(M-RANK+1:M,N-RANK+1:N); +C SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N), +C if RANK < MIN( M, N ), or of +C R(M-RANK+1:M,N-RANK+1:N), otherwise. +C If the triangular factorization is a rank-revealing one +C (which will be the case if the trailing rows were well- +C conditioned), then SVAL(1) will also be an estimate for +C the largest singular value of A, and SVAL(2) and SVAL(3) +C will be estimates for the RANK-th and (RANK+1)-st singular +C values of A, respectively. +C By examining these values, one can confirm that the rank +C is well defined with respect to the chosen value of RCOND. +C The ratio SVAL(1)/SVAL(2) is an estimate of the condition +C number of R(M-RANK+1:M,N-RANK+1:N). +C +C JPVT (output) INTEGER array, dimension ( M ) +C If JPVT(i) = k, then the i-th row of P*A was the k-th row +C of A. +C +C TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) +C The trailing RANK elements of TAU contain the scalar +C factors of the elementary reflectors. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension ( 3*M-1 ) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes a truncated RQ factorization with row +C pivoting of A, P * A = R * Q, with R defined above, and, +C during this process, finds the largest trailing submatrix whose +C estimated condition number is less than 1/RCOND, taking the +C possible positive value of SVLMAX into account. This is performed +C using an adaptation of the LAPACK incremental condition estimation +C scheme and a slightly modified rank decision test. The +C factorization process stops when RANK has been determined. +C +C The matrix Q is represented as a product of elementary reflectors +C +C Q = H(k-rank+1) H(k-rank+2) . . . H(k), where k = min(m,n). +C +C Each H(i) has the form +C +C H = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit +C in A(m-k+i,1:n-k+i-1), and tau in TAU(i). +C +C The matrix P is represented in jpvt as follows: If +C jpvt(j) = i +C then the jth row of P is the ith canonical unit vector. +C +C REFERENCES +C +C [1] Bischof, C.H. and P. Tang. +C Generalizing Incremental Condition Estimation. +C LAPACK Working Notes 32, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-132, +C May 1991. +C +C [2] Bischof, C.H. and P. Tang. +C Robust Incremental Condition Estimation. +C LAPACK Working Notes 33, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-133, +C May 1991. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward... [truncated message content] |
From: <par...@us...> - 2009-11-27 18:27:55
|
Revision: 6544 http://octave.svn.sourceforge.net/octave/?rev=6544&view=rev Author: paramaniac Date: 2009-11-27 17:57:18 +0000 (Fri, 27 Nov 2009) Log Message: ----------- control-oo: fix zero Modified Paths: -------------- trunk/octave-forge/extra/control-oo/inst/@ss/__zero__.m trunk/octave-forge/extra/control-oo/src/slab08nd.cc Modified: trunk/octave-forge/extra/control-oo/inst/@ss/__zero__.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/@ss/__zero__.m 2009-11-27 14:35:20 UTC (rev 6543) +++ trunk/octave-forge/extra/control-oo/inst/@ss/__zero__.m 2009-11-27 17:57:18 UTC (rev 6544) @@ -27,7 +27,7 @@ function [zer, gain] = __zero__ (sys) if (isempty (sys.a)) - zer = []; + zer = zeros (0, 1); else [alphar, alphai, beta] = slab08nd (sys.a, sys.b, sys.c, sys.d); zer = (alphar + i*alphai) ./ beta; @@ -35,11 +35,17 @@ lzer = length (zer); n = rows (sys.a); + m = columns (sys.b); + p = rows (sys.c); - if (lzer == n) - gain = sys.d; + if (m == 1 && p == 1) + if (lzer == n) + gain = sys.d; + else + gain = sys.c * (sys.a^(n-1-lzer)) * sys.b; + endif else - gain = sys.c * (sys.a^(n-1-lzer)) * sys.b; + gain = []; endif endfunction \ No newline at end of file Modified: trunk/octave-forge/extra/control-oo/src/slab08nd.cc =================================================================== --- trunk/octave-forge/extra/control-oo/src/slab08nd.cc 2009-11-27 14:35:20 UTC (rev 6543) +++ trunk/octave-forge/extra/control-oo/src/slab08nd.cc 2009-11-27 17:57:18 UTC (rev 6544) @@ -176,7 +176,7 @@ int ldvr = 1; double* work; - int lwork = 8*nu; + int lwork = max (1, 8*nu); vl = new double[ldvl]; vr = new double[ldvr]; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <par...@us...> - 2009-11-29 04:17:21
|
Revision: 6551 http://octave.svn.sourceforge.net/octave/?rev=6551&view=rev Author: paramaniac Date: 2009-11-29 04:17:08 +0000 (Sun, 29 Nov 2009) Log Message: ----------- control-oo: add L-inf norm (SLICOT AB13DD) Modified Paths: -------------- trunk/octave-forge/extra/control-oo/inst/@lti/norm.m trunk/octave-forge/extra/control-oo/src/Makefile Added Paths: ----------- trunk/octave-forge/extra/control-oo/src/AB13DD.f trunk/octave-forge/extra/control-oo/src/AB13DX.f trunk/octave-forge/extra/control-oo/src/MA01AD.f trunk/octave-forge/extra/control-oo/src/MA02AD.f trunk/octave-forge/extra/control-oo/src/MA02ID.f trunk/octave-forge/extra/control-oo/src/MB01SD.f trunk/octave-forge/extra/control-oo/src/MB02RD.f trunk/octave-forge/extra/control-oo/src/MB02RZ.f trunk/octave-forge/extra/control-oo/src/MB02SD.f trunk/octave-forge/extra/control-oo/src/MB02SZ.f trunk/octave-forge/extra/control-oo/src/MB03XD.f trunk/octave-forge/extra/control-oo/src/MB03XP.f trunk/octave-forge/extra/control-oo/src/MB03XU.f trunk/octave-forge/extra/control-oo/src/MB03YA.f trunk/octave-forge/extra/control-oo/src/MB03YD.f trunk/octave-forge/extra/control-oo/src/MB03YT.f trunk/octave-forge/extra/control-oo/src/MB04DD.f trunk/octave-forge/extra/control-oo/src/MB04QB.f trunk/octave-forge/extra/control-oo/src/MB04QC.f trunk/octave-forge/extra/control-oo/src/MB04QF.f trunk/octave-forge/extra/control-oo/src/MB04QU.f trunk/octave-forge/extra/control-oo/src/MB04TB.f trunk/octave-forge/extra/control-oo/src/MB04TS.f trunk/octave-forge/extra/control-oo/src/TG01AD.f trunk/octave-forge/extra/control-oo/src/TG01BD.f trunk/octave-forge/extra/control-oo/src/UE01MD.f Modified: trunk/octave-forge/extra/control-oo/inst/@lti/norm.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/@lti/norm.m 2009-11-28 16:43:50 UTC (rev 6550) +++ trunk/octave-forge/extra/control-oo/inst/@lti/norm.m 2009-11-29 04:17:08 UTC (rev 6551) @@ -20,7 +20,7 @@ ## @deftypefn {Function File} {@var{gain} =} norm (@var{sys}, @var{2}) ## @deftypefnx {Function File} {@var{gain} =} norm (@var{sys}, @var{inf}) ## @deftypefnx {Function File} {@var{gain} =} norm (@var{sys}, @var{inf}, @var{tol}) -## Return norm of LTI model. +## Return norm of LTI model. L-infinity norm uses SLICOT AB13DD. ## @end deftypefn ## Author: A. S. Hodel <a.s...@en...> @@ -33,11 +33,9 @@ ## Date: November 2009 ## Version: 0.1 -## TODO: Use Fortran code from Slicot +function [gain, varargout] = norm (sys, ntype = "2", tol = 0.01) -function gain = norm (sys, ntype = "2", tol = 0.001) - - if (nargin > 3) # norm () is catched by built-in function + if (nargin > 3) # norm () is caught by built-in function print_usage (); endif @@ -60,7 +58,7 @@ gain = h2norm (sys); case "inf" - gain = hinfnorm (sys, tol); + [gain, varargout{1}] = linfnorm (sys, tol); otherwise error ("lti: norm: invalid norm type"); @@ -93,80 +91,27 @@ endfunction -function g = hinfnorm (sys, tol = 0.001, gmin = 1e-9, gmax = 1e9, ptol = 1e-9) +function [gain, wpeak] = linfnorm (sys, tol = 0.01) - if (isstable (sys)) - - [A, B, C, D, tsam] = ssdata (sys); - n = rows (A); # states - m = columns (B); # inputs - p = rows (C); # outputs - dflg = (tsam > 0); - - Dnrm = norm (D); - if (nargin < 3) - gmin = max (gmin, Dnrm); # min gain value - elseif (gmin < Dnrm) - warning ("hinfnorm: setting Gmin=||D||=%g", Dnrm); + [a, b, c, d, tsam] = ssdata (sys); + tol = max (tol, 100*eps); + + [fpeak, gpeak] = slab13dd (a, b, c, d, tsam, tol); + + if (fpeak(2) > 0) + if (tsam > 0) + wpeak = fpeak(1) / tsam; + else + wpeak = fpeak(1); endif - - In = eye (n); - Im = eye (m); - Ip = eye (p); - - ## find the Hinf norm via binary search - while (gmax/gmin - 1 > tol) - g = (gmax+gmin)/2; - - if (dflg) - ## multiply g's through in formulas to avoid extreme magnitudes... - Rg = g^2*Im - D'*D; - Ak = A + (B/Rg)*D'*C; - Ck = g^2*C'*((g^2*Ip-D*D')\C); - - ## set up symplectic generalized eigenvalue problem per Iglesias & Glover - s1 = [Ak , zeros(n); -Ck, In]; - s2 = [In, -(B/Rg)*B'; zeros(n), Ak']; - - ## guard against roundoff again: zero out extremely small values - ## prior to balancing - s1 = s1 .* (abs(s1) > ptol*norm(s1,"inf")); - s2 = s2 .* (abs(s2) > ptol*norm(s2,"inf")); - [cc, dd, s1, s2] = balance (s1, s2); - [qza, qzb, zz, pls] = qz (s1, s2, "S"); # ordered qz decomposition - eigerr = abs (abs(pls)-1); - normH = norm ([s1, s2]); - Hb = [s1, s2]; - - ## check R - B' X B condition (Iglesias and Glover's paper) - X = zz((n+1):(2*n),1:n)/zz(1:n,1:n); - dcondfailed = min (real (eig (Rg - B'*X*B)) < ptol); - else - Rinv = inv(g*g*Im - (D' * D)); - H = [A + B*Rinv*D'*C, B*Rinv*B'; - -C'*(Ip + D*Rinv*D')*C, -(A + B*Rinv*D'*C)']; - - ## guard against roundoff: zero out extremely small values prior - ## to balancing - H = H .* (abs (H) > ptol * norm (H, "inf")); - [DD, Hb] = balance (H); - pls = eig (Hb); - eigerr = abs (real (pls)); - normH = norm (H); - dcondfailed = 0; # digital condition; doesn't apply here - endif - - if ((min (eigerr) <= ptol * normH) | dcondfailed) - gmin = g; - else - gmax = g; - endif - endwhile - else - warning ("norm: Hinf: unstable system (ptol=%g), returning Inf", ptol); - g = Inf; + wpeak = inf; endif + + if (gpeak(2) > 0) + gain = gpeak(1); + else + gain = inf; + endif endfunction - Added: trunk/octave-forge/extra/control-oo/src/AB13DD.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/AB13DD.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/AB13DD.f 2009-11-29 04:17:08 UTC (rev 6551) @@ -0,0 +1,1870 @@ + SUBROUTINE AB13DD( DICO, JOBE, EQUIL, JOBD, N, M, P, FPEAK, + $ A, LDA, E, LDE, B, LDB, C, LDC, D, LDD, GPEAK, + $ TOL, IWORK, DWORK, LDWORK, CWORK, LCWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To compute the L-infinity norm of a continuous-time or +C discrete-time system, either standard or in the descriptor form, +C +C -1 +C G(lambda) = C*( lambda*E - A ) *B + D . +C +C The norm is finite if and only if the matrix pair (A,E) has no +C eigenvalue on the boundary of the stability domain, i.e., the +C imaginary axis, or the unit circle, respectively. It is assumed +C that the matrix E is nonsingular. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system, as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBE CHARACTER*1 +C Specifies whether E is a general square or an identity +C matrix, as follows: +C = 'G': E is a general square matrix; +C = 'I': E is the identity matrix. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the system (A,E,B,C) or (A,B,C), as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears in +C the given state space model: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C P (input) INTEGER +C The row size of the matrix C. P >= 0. +C +C FPEAK (input/output) DOUBLE PRECISION array, dimension (2) +C On entry, this parameter must contain an estimate of the +C frequency where the gain of the frequency response would +C achieve its peak value. Setting FPEAK(2) = 0 indicates an +C infinite frequency. An accurate estimate could reduce the +C number of iterations of the iterative algorithm. If no +C estimate is available, set FPEAK(1) = 0, and FPEAK(2) = 1. +C FPEAK(1) >= 0, FPEAK(2) >= 0. +C On exit, if INFO = 0, this array contains the frequency +C OMEGA, where the gain of the frequency response achieves +C its peak value GPEAK, i.e., +C +C || G ( j*OMEGA ) || = GPEAK , if DICO = 'C', or +C +C j*OMEGA +C || G ( e ) || = GPEAK , if DICO = 'D', +C +C where OMEGA = FPEAK(1), if FPEAK(2) > 0, and OMEGA is +C infinite, if FPEAK(2) = 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state dynamics matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C If JOBE = 'G', the leading N-by-N part of this array must +C contain the descriptor matrix E of the system. +C If JOBE = 'I', then E is assumed to be the identity +C matrix and is not referenced. +C +C LDE INTEGER +C The leading dimension of the array E. +C LDE >= MAX(1,N), if JOBE = 'G'; +C LDE >= 1, if JOBE = 'I'. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C If JOBD = 'D', the leading P-by-M part of this array must +C contain the direct transmission matrix D. +C The array D is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P), if JOBD = 'D'; +C LDD >= 1, if JOBD = 'Z'. +C +C GPEAK (output) DOUBLE PRECISION array, dimension (2) +C The L-infinity norm of the system, i.e., the peak gain +C of the frequency response (as measured by the largest +C singular value in the MIMO case), coded in the same way +C as FPEAK. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used to set the accuracy in determining the +C norm. 0 <= TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= K, where K can be computed using the following +C pseudo-code (or the Fortran code included in the routine) +C +C d = 6*MIN(P,M); +C c = MAX( 4*MIN(P,M) + MAX(P,M), d ); +C if ( MIN(P,M) = 0 ) then +C K = 1; +C else if( N = 0 or B = 0 or C = 0 ) then +C if( JOBD = 'D' ) then +C K = P*M + c; +C else +C K = 1; +C end +C else +C if ( DICO = 'D' ) then +C b = 0; e = d; +C else +C b = N*(N+M); e = c; +C if ( JOBD = Z' ) then b = b + P*M; end +C end +C if ( JOBD = 'D' ) then +C r = P*M; +C if ( JOBE = 'I', DICO = 'C', +C N > 0, B <> 0, C <> 0 ) then +C K = P*P + M*M; +C r = r + N*(P+M); +C else +C K = 0; +C end +C K = K + r + c; r = r + MIN(P,M); +C else +C r = 0; K = 0; +C end +C r = r + N*(N+P+M); +C if ( JOBE = 'G' ) then +C r = r + N*N; +C if ( EQUIL = 'S' ) then +C K = MAX( K, r + 9*N ); +C end +C K = MAX( K, r + 4*N + MAX( M, 2*N*N, N+b+e ) ); +C else +C K = MAX( K, r + N + +C MAX( M, P, N*N+2*N, 3*N+b+e ) ); +C end +C w = 0; +C if ( JOBE = 'I', DICO = 'C' ) then +C w = r + 4*N*N + 11*N; +C if ( JOBD = 'D' ) then +C w = w + MAX(M,P) + N*(P+M); +C end +C end +C if ( JOBE = 'E' or DICO = 'D' or JOBD = 'D' ) then +C w = MAX( w, r + 6*N + (2*N+P+M)*(2*N+P+M) + +C MAX( 2*(N+P+M), 8*N*N + 16*N ) ); +C end +C K = MAX( 1, K, w, r + 2*N + e ); +C end +C +C For good performance, LDWORK must generally be larger. +C +C An easily computable upper bound is +C +C K = MAX( 1, 15*N*N + P*P + M*M + (6*N+3)*(P+M) + 4*P*M + +C N*M + 22*N + 7*MIN(P,M) ). +C +C The smallest workspace is obtained for DICO = 'C', +C JOBE = 'I', and JOBD = 'Z', namely +C +C K = MAX( 1, N*N + N*P + N*M + N + +C MAX( N*N + N*M + P*M + 3*N + c, +C 4*N*N + 10*N ) ). +C +C for which an upper bound is +C +C K = MAX( 1, 6*N*N + N*P + 2*N*M + P*M + 11*N + MAX(P,M) + +C 6*MIN(P,M) ). +C +C CWORK COMPLEX*16 array, dimension (LCWORK) +C On exit, if INFO = 0, CWORK(1) contains the optimal +C LCWORK. +C +C LCWORK INTEGER +C The dimension of the array CWORK. +C LCWORK >= 1, if N = 0, or B = 0, or C = 0; +C LCWORK >= MAX(1, (N+M)*(N+P) + 2*MIN(P,M) + MAX(P,M)), +C otherwise. +C For good performance, LCWORK must generally be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the matrix E is (numerically) singular; +C = 2: the (periodic) QR (or QZ) algorithm for computing +C eigenvalues did not converge; +C = 3: the SVD algorithm for computing singular values did +C not converge; +C = 4: the tolerance is too small and the algorithm did +C not converge. +C +C METHOD +C +C The routine implements the method presented in [1], with +C extensions and refinements for improving numerical robustness and +C efficiency. Structure-exploiting eigenvalue computations for +C Hamiltonian matrices are used if JOBE = 'I', DICO = 'C', and the +C symmetric matrices to be implicitly inverted are not too ill- +C conditioned. Otherwise, generalized eigenvalue computations are +C used in the iterative algorithm of [1]. +C +C REFERENCES +C +C [1] Bruinsma, N.A. and Steinbuch, M. +C A fast algorithm to compute the Hinfinity-norm of a transfer +C function matrix. +C Systems & Control Letters, vol. 14, pp. 287-293, 1990. +C +C NUMERICAL ASPECTS +C +C If the algorithm does not converge in MAXIT = 30 iterations +C (INFO = 4), the tolerance must be increased. +C +C FURTHER COMMENTS +C +C If the matrix E is singular, other SLICOT Library routines +C could be used before calling AB13DD, for removing the singular +C part of the system. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2001. +C V. Sima, Research Institute for Informatics, Bucharest, May 2001. +C Partly based on SLICOT Library routine AB13CD by P.Hr. Petkov, +C D.W. Gu and M.M. Konstantinov. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001, +C May 2003, Aug. 2005, March 2008, May 2009, Sep. 2009. +C +C KEYWORDS +C +C H-infinity optimal control, robust control, system norm. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 30 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) + DOUBLE PRECISION ZERO, ONE, TWO, FOUR, P25 + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ FOUR = 4.0D+0, P25 = 0.25D+0 ) + DOUBLE PRECISION TEN, HUNDRD, THOUSD + PARAMETER ( TEN = 1.0D+1, HUNDRD = 1.0D+2, + $ THOUSD = 1.0D+3 ) +C .. +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOBD, JOBE + INTEGER INFO, LCWORK, LDA, LDB, LDC, LDD, LDE, LDWORK, + $ M, N, P + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + COMPLEX*16 CWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), DWORK( * ), E( LDE, * ), + $ FPEAK( 2 ), GPEAK( 2 ) + INTEGER IWORK( * ) +C .. +C .. Local Scalars .. + CHARACTER VECT + LOGICAL DISCR, FULLE, ILASCL, ILESCL, LEQUIL, NODYN, + $ USEPEN, WITHD + INTEGER I, IA, IAR, IAS, IB, IBS, IBT, IBV, IC, ICU, + $ ID, IE, IERR, IES, IH, IH12, IHI, II, ILO, IM, + $ IMIN, IPA, IPE, IR, IS, ISB, ISC, ISL, ITAU, + $ ITER, IU, IV, IWRK, J, K, LW, MAXCWK, MAXWRK, + $ MINCWR, MINPM, MINWRK, N2, N2PM, NEI, NN, NWS, + $ NY, PM + DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNORM, BOUND, CNORM, + $ ENRM, ENRMTO, EPS, FPEAKI, FPEAKS, GAMMA, + $ GAMMAL, GAMMAS, MAXRED, OMEGA, PI, RAT, RCOND, + $ RTOL, SAFMAX, SAFMIN, SMLNUM, TM, TOLER, WMAX, + $ WRMIN +C .. +C .. Local Arrays .. + DOUBLE PRECISION TEMP( 1 ) +C .. +C .. External Functions .. + DOUBLE PRECISION AB13DX, DLAMCH, DLANGE, DLAPY2 + LOGICAL LSAME + EXTERNAL AB13DX, DLAMCH, DLANGE, DLAPY2, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DGEBAL, DGEHRD, DGEMM, DGEQRF, DGESVD, + $ DGGBAL, DGGEV, DHGEQZ, DHSEQR, DLABAD, DLACPY, + $ DLASCL, DLASRT, DORGQR, DORMHR, DSWAP, DSYRK, + $ DTRCON, MA02AD, MB01SD, MB03XD, TB01ID, TG01AD, + $ TG01BD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, ATAN, ATAN2, COS, DBLE, INT, LOG, MAX, + $ MIN, SIN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar parameters. +C + N2 = 2*N + NN = N*N + PM = P + M + N2PM = N2 + PM + MINPM = MIN( P, M ) + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + FULLE = LSAME( JOBE, 'G' ) + LEQUIL = LSAME( EQUIL, 'S' ) + WITHD = LSAME( JOBD, 'D' ) +C + IF( .NOT. ( DISCR .OR. LSAME( DICO, 'C' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( FULLE .OR. LSAME( JOBE, 'I' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LEQUIL .OR. LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( MIN( FPEAK( 1 ), FPEAK( 2 ) ).LT.ZERO ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDE.LT.1 .OR. ( FULLE .AND. LDE.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN + INFO = -18 + ELSE IF( TOL.LT.ZERO .OR. TOL.GE.ONE ) THEN + INFO = -20 + ELSE + BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) + CNORM = DLANGE( '1-norm', P, N, C, LDC, DWORK ) + NODYN = N.EQ.0 .OR. MIN( BNORM, CNORM ).EQ.ZERO + USEPEN = FULLE .OR. DISCR +C +C Compute workspace. +C + ID = 6*MINPM + IC = MAX( 4*MINPM + MAX( P, M ), ID ) + IF( MINPM.EQ.0 ) THEN + MINWRK = 1 + ELSE IF( NODYN ) THEN + IF( WITHD ) THEN + MINWRK = P*M + IC + ELSE + MINWRK = 1 + END IF + ELSE + IF ( DISCR ) THEN + IB = 0 + IE = ID + ELSE + IB = N*( N + M ) + IF ( .NOT.WITHD ) + $ IB = IB + P*M + IE = IC + END IF + IF ( WITHD ) THEN + IR = P*M + IF ( .NOT.USEPEN ) THEN + MINWRK = P*P + M*M + IR = IR + N*PM + ELSE + MINWRK = 0 + END IF + MINWRK = MINWRK + IR + IC + IR = IR + MINPM + ELSE + IR = 0 + MINWRK = 0 + END IF + IR = IR + N*( N + PM ) + IF ( FULLE ) THEN + IR = IR + NN + IF ( LEQUIL ) + $ MINWRK = MAX( MINWRK, IR + 9*N ) + MINWRK = MAX( MINWRK, IR + 4*N + MAX( M, 2*NN, + $ N + IB + IE ) ) + ELSE + MINWRK = MAX( MINWRK, IR + N + MAX( M, P, NN + N2, + $ 3*N + IB + IE ) ) + END IF + LW = 0 + IF ( .NOT.USEPEN ) THEN + LW = IR + 4*NN + 11*N + IF ( WITHD ) + $ LW = LW + MAX( M, P ) + N*PM + END IF + IF ( USEPEN .OR. WITHD ) + $ LW = MAX( LW, IR + 6*N + N2PM*N2PM + + $ MAX( N2PM + PM, 8*( NN + N2 ) ) ) + MINWRK = MAX( 1, MINWRK, LW, IR + N2 + IE ) + END IF +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -23 + ELSE + IF ( NODYN ) THEN + MINCWR = 1 + ELSE + MINCWR = MAX( 1, ( N + M )*( N + P ) + + $ 2*MINPM + MAX( P, M ) ) + END IF + IF( LCWORK.LT.MINCWR ) + $ INFO = -25 + END IF + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'AB13DD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( M.EQ.0 .OR. P.EQ.0 ) THEN + GPEAK( 1 ) = ZERO + FPEAK( 1 ) = ZERO + GPEAK( 2 ) = ONE + FPEAK( 2 ) = ONE + DWORK( 1 ) = ONE + CWORK( 1 ) = ONE + RETURN + END IF +C +C Determine the maximum singular value of G(infinity) = D . +C If JOBE = 'I' and DICO = 'C', the full SVD of D, D = U*S*V', is +C computed and saved for later use. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + ID = 1 + IF ( WITHD ) THEN + IS = ID + P*M + IF ( USEPEN .OR. NODYN ) THEN + IU = IS + MINPM + IV = IU + IWRK = IV + VECT = 'N' + ELSE + IBV = IS + MINPM + ICU = IBV + N*M + IU = ICU + P*N + IV = IU + P*P + IWRK = IV + M*M + VECT = 'A' + END IF +C +C Workspace: need P*M + MIN(P,M) + V + +C MAX( 3*MIN(P,M) + MAX(P,M), 5*MIN(P,M) ), +C where V = N*(M+P) + P*P + M*M, +C if JOBE = 'I' and DICO = 'C', +C and N > 0, B <> 0, C <> 0, +C V = 0, otherwise; +C prefer larger. +C + CALL DLACPY( 'Full', P, M, D, LDD, DWORK( ID ), P ) + CALL DGESVD( VECT, VECT, P, M, DWORK( ID ), P, DWORK( IS ), + $ DWORK( IU ), P, DWORK( IV ), M, DWORK( IWRK ), + $ LDWORK-IWRK+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 3 + RETURN + END IF + GAMMAL = DWORK( IS ) + MAXWRK = INT( DWORK( IWRK ) ) + IWRK - 1 +C +C Restore D for later calculations. +C + CALL DLACPY( 'Full', P, M, D, LDD, DWORK( ID ), P ) + ELSE + IWRK = 1 + GAMMAL = ZERO + MAXWRK = 1 + END IF +C +C Quick return if possible. +C + IF( NODYN ) THEN + GPEAK( 1 ) = GAMMAL + FPEAK( 1 ) = ZERO + GPEAK( 2 ) = ONE + FPEAK( 2 ) = ONE + DWORK( 1 ) = MAXWRK + CWORK( 1 ) = ONE + RETURN + END IF +C + IF ( .NOT.USEPEN .AND. WITHD ) THEN +C +C Standard continuous-time case, D <> 0: Compute B*V and C'*U . +C + CALL DGEMM( 'No Transpose', 'Transpose', N, M, M, ONE, B, LDB, + $ DWORK( IV ), M, ZERO, DWORK( IBV ), N ) + CALL DGEMM( 'Transpose', 'No Transpose', N, P, P, ONE, C, + $ LDC, DWORK( IU ), P, ZERO, DWORK( ICU ), N ) +C +C U and V are no longer needed: free their memory space. +C Total workspace here: need P*M + MIN(P,M) + N*(M+P) +C (JOBE = 'I', DICO = 'C', JOBD = 'D'). +C + IWRK = IU + END IF +C +C Get machine constants. +C + EPS = DLAMCH( 'Epsilon' ) + SAFMIN = DLAMCH( 'Safe minimum' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + SMLNUM = SQRT( SAFMIN ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM + TOLER = SQRT( EPS ) +C +C Initiate the transformation of the system to an equivalent one, +C to be used for eigenvalue computations. +C +C Additional workspace: need N*N + N*M + P*N + 2*N, if JOBE = 'I'; +C 2*N*N + N*M + P*N + 2*N, if JOBE = 'G'. +C + IA = IWRK + IE = IA + NN + IF ( FULLE ) THEN + IB = IE + NN + ELSE + IB = IE + END IF + IC = IB + N*M + IR = IC + P*N + II = IR + N + IBT = II + N +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IA ), N ) + CALL DLACPY( 'Full', N, M, B, LDB, DWORK( IB ), N ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK( IC ), P ) +C +C Scale A if maximum element is outside the range [SMLNUM,BIGNUM]. +C + ANRM = DLANGE( 'Max', N, N, DWORK( IA ), N, DWORK ) + ILASCL = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ANRMTO = SMLNUM + ILASCL = .TRUE. + ELSE IF( ANRM.GT.BIGNUM ) THEN + ANRMTO = BIGNUM + ILASCL = .TRUE. + END IF + IF( ILASCL ) + $ CALL DLASCL( 'General', 0, 0, ANRM, ANRMTO, N, N, DWORK( IA ), + $ N, IERR ) +C + IF ( FULLE ) THEN +C +C Descriptor system. +C +C Additional workspace: need N. +C + IWRK = IBT + N + CALL DLACPY( 'Full', N, N, E, LDE, DWORK( IE ), N ) +C +C Scale E if maximum element is outside the range +C [SMLNUM,BIGNUM]. +C + ENRM = DLANGE( 'Max', N, N, DWORK( IE ), N, DWORK ) + ILESCL = .FALSE. + IF( ENRM.GT.ZERO .AND. ENRM.LT.SMLNUM ) THEN + ENRMTO = SMLNUM + ILESCL = .TRUE. + ELSE IF( ENRM.GT.BIGNUM ) THEN + ENRMTO = BIGNUM + ILESCL = .TRUE. + ELSE IF( ENRM.EQ.ZERO ) THEN +C +C Error return: Matrix E is 0. +C + INFO = 1 + RETURN + END IF + IF( ILESCL ) + $ CALL DLASCL( 'General', 0, 0, ENRM, ENRMTO, N, N, + $ DWORK( IE ), N, IERR ) +C +C Equilibrate the system, if required. +C +C Additional workspace: need 6*N. +C + IF( LEQUIL ) + $ CALL TG01AD( 'All', N, N, M, P, ZERO, DWORK( IA ), N, + $ DWORK( IE ), N, DWORK( IB ), N, DWORK( IC ), P, + $ DWORK( II ), DWORK( IR ), DWORK( IWRK ), + $ IERR ) +C +C For efficiency of later calculations, the system (A,E,B,C) is +C reduced to an equivalent one with the state matrix A in +C Hessenberg form, and E upper triangular. +C First, permute (A,E) to make it more nearly triangular. +C + CALL DGGBAL( 'Permute', N, DWORK( IA ), N, DWORK( IE ), N, ILO, + $ IHI, DWORK( II ), DWORK( IR ), DWORK( IWRK ), + $ IERR ) +C +C Apply the permutations to (the copies of) B and C. +C + DO 10 I = N, IHI + 1, -1 + K = DWORK( II+I-1 ) + IF( K.NE.I ) + $ CALL DSWAP( M, DWORK( IB+I-1 ), N, + $ DWORK( IB+K-1 ), N ) + K = DWORK( IR+I-1 ) + IF( K.NE.I ) + $ CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, + $ DWORK( IC+(K-1)*P ), 1 ) + 10 CONTINUE +C + DO 20 I = 1, ILO - 1 + K = DWORK( II+I-1 ) + IF( K.NE.I ) + $ CALL DSWAP( M, DWORK( IB+I-1 ), N, + $ DWORK( IB+K-1 ), N ) + K = DWORK( IR+I-1 ) + IF( K.NE.I ) + $ CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, + $ DWORK( IC+(K-1)*P ), 1 ) + 20 CONTINUE +C +C Reduce (A,E) to generalized Hessenberg form and apply the +C transformations to B and C. +C Additional workspace: need N + MAX(N,M); +C prefer N + MAX(N,M)*NB. +C + CALL TG01BD( 'General', 'No Q', 'No Z', N, M, P, ILO, IHI, + $ DWORK( IA ), N, DWORK( IE ), N, DWORK( IB ), N, + $ DWORK( IC ), P, DWORK, 1, DWORK, 1, DWORK( IWRK ), + $ LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Check whether matrix E is nonsingular. +C Additional workspace: need 3*N. +C + CALL DTRCON( '1-norm', 'Upper', 'Non Unit', N, DWORK( IE ), N, + $ RCOND, DWORK( IWRK ), IWORK, IERR ) + IF( RCOND.LE.TEN*DBLE( N )*EPS ) THEN +C +C Error return: Matrix E is numerically singular. +C + INFO = 1 + RETURN + END IF +C +C Perform QZ algorithm, computing eigenvalues. The generalized +C Hessenberg form is saved for later use. +C Additional workspace: need 2*N*N + N; +C prefer larger. +C + IAS = IWRK + IES = IAS + NN + IWRK = IES + NN + CALL DLACPY( 'Full', N, N, DWORK( IA ), N, DWORK( IAS ), N ) + CALL DLACPY( 'Full', N, N, DWORK( IE ), N, DWORK( IES ), N ) + CALL DHGEQZ( 'Eigenvalues', 'No Vectors', 'No Vectors', N, ILO, + $ IHI, DWORK( IAS ), N, DWORK( IES ), N, + $ DWORK( IR ), DWORK( II ), DWORK( IBT ), DWORK, N, + $ DWORK, N, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Check if unscaling would cause over/underflow; if so, rescale +C eigenvalues (DWORK( IR+I-1 ),DWORK( II+I-1 ),DWORK( IBT+I-1 )) +C so DWORK( IBT+I-1 ) is on the order of E(I,I) and +C DWORK( IR+I-1 ) and DWORK( II+I-1 ) are on the order of A(I,I). +C + IF( ILASCL ) THEN +C + DO 30 I = 1, N + IF( DWORK( II+I-1 ).NE.ZERO ) THEN + IF( ( DWORK( IR+I-1 ) / SAFMAX ).GT.( ANRMTO / ANRM ) + $ .OR. + $ ( SAFMIN / DWORK( IR+I-1 ) ).GT.( ANRM / ANRMTO ) + $ ) THEN + TM = ABS( DWORK( IA+(I-1)*N+I ) / DWORK( IR+I-1 ) ) + DWORK( IBT+I-1 ) = DWORK( IBT+I-1 )*TM + DWORK( IR+I-1 ) = DWORK( IR+I-1 )*TM + DWORK( II+I-1 ) = DWORK( II+I-1 )*TM + ELSE IF( ( DWORK( II+I-1 ) / SAFMAX ).GT. + $ ( ANRMTO / ANRM ) .OR. + $ ( SAFMIN / DWORK( II+I-1 ) ).GT.( ANRM / ANRMTO ) ) + $ THEN + TM = ABS( DWORK( IA+I*N+I ) / DWORK( II+I-1 ) ) + DWORK( IBT+I-1 ) = DWORK( IBT+I-1 )*TM + DWORK( IR+I-1 ) = DWORK( IR+I-1 )*TM + DWORK( II+I-1 ) = DWORK( II+I-1 )*TM + END IF + END IF + 30 CONTINUE +C + END IF +C + IF( ILESCL ) THEN +C + DO 40 I = 1, N + IF( DWORK( II+I-1 ).NE.ZERO ) THEN + IF( ( DWORK( IBT+I-1 ) / SAFMAX ).GT.( ENRMTO / ENRM ) + $ .OR. + $ ( SAFMIN / DWORK( IBT+I-1 ) ).GT.( ENRM / ENRMTO ) + $ ) THEN + TM = ABS( DWORK( IE+(I-1)*N+I ) / DWORK( IBT+I-1 )) + DWORK( IBT+I-1 ) = DWORK( IBT+I-1 )*TM + DWORK( IR+I-1 ) = DWORK( IR+I-1 )*TM + DWORK( II+I-1 ) = DWORK( II+I-1 )*TM + END IF + END IF + 40 CONTINUE +C + END IF +C +C Undo scaling. +C + IF( ILASCL ) THEN + CALL DLASCL( 'Hessenberg', 0, 0, ANRMTO, ANRM, N, N, + $ DWORK( IA ), N, IERR ) + CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, + $ DWORK( IR ), N, IERR ) + CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, + $ DWORK( II ), N, IERR ) + END IF +C + IF( ILESCL ) THEN + CALL DLASCL( 'Upper', 0, 0, ENRMTO, ENRM, N, N, + $ DWORK( IE ), N, IERR ) + CALL DLASCL( 'General', 0, 0, ENRMTO, ENRM, N, 1, + $ DWORK( IBT ), N, IERR ) + END IF +C + ELSE +C +C Standard state-space system. +C + IF( LEQUIL ) THEN +C +C Equilibrate the system. +C + MAXRED = HUNDRD + CALL TB01ID( 'All', N, M, P, MAXRED, DWORK( IA ), N, + $ DWORK( IB ), N, DWORK( IC ), P, DWORK( II ), + $ IERR ) + END IF +C +C For efficiency of later calculations, the system (A,B,C) is +C reduced to a similar one with the state matrix in Hessenberg +C form. +C +C First, permute the matrix A to make it more nearly triangular +C and apply the permutations to B and C. +C + CALL DGEBAL( 'Permute', N, DWORK( IA ), N, ILO, IHI, + $ DWORK( IR ), IERR ) +C + DO 50 I = N, IHI + 1, -1 + K = DWORK( IR+I-1 ) + IF( K.NE.I ) THEN + CALL DSWAP( M, DWORK( IB+I-1 ), N, + $ DWORK( IB+K-1 ), N ) + CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, + $ DWORK( IC+(K-1)*P ), 1 ) + END IF + 50 CONTINUE +C + DO 60 I = 1, ILO - 1 + K = DWORK( IR+I-1 ) + IF( K.NE.I ) THEN + CALL DSWAP( M, DWORK( IB+I-1 ), N, + $ DWORK( IB+K-1 ), N ) + CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, + $ DWORK( IC+(K-1)*P ), 1 ) + END IF + 60 CONTINUE +C +C Reduce A to upper Hessenberg form and apply the transformations +C to B and C. +C Additional workspace: need N; (from II) +C prefer N*NB. +C + ITAU = IR + IWRK = ITAU + N + CALL DGEHRD( N, ILO, IHI, DWORK( IA ), N, DWORK( ITAU ), + $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Additional workspace: need M; +C prefer M*NB. +C + CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, DWORK( IA ), + $ N, DWORK( ITAU ), DWORK( IB ), N, DWORK( IWRK ), + $ LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Additional workspace: need P; +C prefer P*NB. +C + CALL DORMHR( 'Right', 'NoTranspose', P, N, ILO, IHI, + $ DWORK( IA ), N, DWORK( ITAU ), DWORK( IC ), P, + $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Compute the eigenvalues. The Hessenberg form is saved for +C later use. +C Additional workspace: need N*N + N; (from IBT) +C prefer larger. +C + IAS = IBT + IWRK = IAS + NN + CALL DLACPY( 'Full', N, N, DWORK( IA ), N, DWORK( IAS ), N ) + CALL DHSEQR( 'Eigenvalues', 'No Vectors', N, ILO, IHI, + $ DWORK( IAS ), N, DWORK( IR ), DWORK( II ), DWORK, + $ N, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C + IF( ILASCL ) THEN +C +C Undo scaling for the Hessenberg form of A and eigenvalues. +C + CALL DLASCL( 'Hessenberg', 0, 0, ANRMTO, ANRM, N, N, + $ DWORK( IA ), N, IERR ) + CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, + $ DWORK( IR ), N, IERR ) + CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, + $ DWORK( II ), N, IERR ) + END IF +C + END IF +C +C Look for (generalized) eigenvalues on the boundary of the +C stability domain. (Their existence implies an infinite norm.) +C Additional workspace: need 2*N. (from IAS) +C + IM = IAS + IAR = IM + N + IMIN = II + WRMIN = SAFMAX + BOUND = EPS*THOUSD +C + IF ( DISCR ) THEN + GAMMAL = ZERO +C +C For discrete-time case, compute the logarithm of the non-zero +C eigenvalues and save their moduli and absolute real parts. +C (The logarithms are overwritten on the eigenvalues.) +C Also, find the minimum distance to the unit circle. +C + IF ( FULLE ) THEN +C + DO 70 I = 0, N - 1 + TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + IF ( ( DWORK( IBT+I ).GE.ONE ) .OR. + $ ( DWORK( IBT+I ).LT.ONE .AND. + $ TM.LT.SAFMAX*DWORK( IBT+I ) ) ) THEN + TM = TM / DWORK( IBT+I ) + ELSE +C +C The pencil has too large eigenvalues. SAFMAX is used. +C + TM = SAFMAX + END IF + IF ( TM.NE.ZERO ) THEN + DWORK( II+I ) = ATAN2( DWORK( II+I ), DWORK( IR+I ) ) + DWORK( IR+I ) = LOG( TM ) + END IF + DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + TM = ABS( ONE - TM ) + IF( TM.LT.WRMIN ) THEN + IMIN = II + I + WRMIN = TM + END IF + IM = IM + 1 + DWORK( IAR+I ) = ABS( DWORK( IR+I ) ) + 70 CONTINUE +C + ELSE +C + DO 80 I = 0, N - 1 + TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + IF ( TM.NE.ZERO ) THEN + DWORK( II+I ) = ATAN2( DWORK( II+I ), DWORK( IR+I ) ) + DWORK( IR+I ) = LOG( TM ) + END IF + DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + TM = ABS( ONE - TM ) + IF( TM.LT.WRMIN ) THEN + IMIN = II + I + WRMIN = TM + END IF + IM = IM + 1 + DWORK( IAR+I ) = ABS( DWORK( IR+I ) ) + 80 CONTINUE +C + END IF +C + ELSE +C +C For continuous-time case, save moduli of eigenvalues and +C absolute real parts and find the maximum modulus and minimum +C absolute real part. +C + WMAX = ZERO +C + IF ( FULLE ) THEN +C + DO 90 I = 0, N - 1 + TM = ABS( DWORK( IR+I ) ) + DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + IF ( ( DWORK( IBT+I ).GE.ONE ) .OR. + $ ( DWORK( IBT+I ).LT.ONE .AND. + $ DWORK( IM ).LT.SAFMAX*DWORK( IBT+I ) ) ) + $ THEN + TM = TM / DWORK( IBT+I ) + DWORK( IM ) = DWORK( IM ) / DWORK( IBT+I ) + ELSE + IF ( TM.LT.SAFMAX*DWORK( IBT+I ) ) THEN + TM = TM / DWORK( IBT+I ) + ELSE +C +C The pencil has too large eigenvalues. +C SAFMAX is used. +C + TM = SAFMAX + END IF + DWORK( IM ) = SAFMAX + END IF + IF( TM.LT.WRMIN ) THEN + IMIN = II + I + WRMIN = TM + END IF + DWORK( IAR+I ) = TM + IF( DWORK( IM ).GT.WMAX ) + $ WMAX = DWORK( IM ) + IM = IM + 1 + 90 CONTINUE +C + ELSE +C + DO 100 I = 0, N - 1 + TM = ABS( DWORK( IR+I ) ) + IF( TM.LT.WRMIN ) THEN + IMIN = II + I + WRMIN = TM + END IF + DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + IF( DWORK( IM ).GT.WMAX ) + $ WMAX = DWORK( IM ) + IM = IM + 1 + DWORK( IAR+I ) = TM + 100 CONTINUE +C + END IF +C + BOUND = BOUND + EPS*WMAX +C + END IF +C + IM = IM - N +C + IF( WRMIN.LT.BOUND ) THEN +C +C The L-infinity norm was found as infinite. +C + GPEAK( 1 ) = ONE + GPEAK( 2 ) = ZERO + TM = ABS( DWORK( IMIN ) ) + IF ( DISCR ) + $ TM = ABS( ATAN2( SIN( TM ), COS( TM ) ) ) + FPEAK( 1 ) = TM + IF ( TM.LT.SAFMAX ) THEN + FPEAK( 2 ) = ONE + ELSE + FPEAK( 2 ) = ZERO + END IF +C + DWORK( 1 ) = MAXWRK + CWORK( 1 ) = ONE + RETURN + END IF +C +C Determine the maximum singular value of +C G(lambda) = C*inv(lambda*E - A)*B + D, +C over a selected set of frequencies. Besides the frequencies w = 0, +C w = pi (if DICO = 'D'), and the given value FPEAK, this test set +C contains the peak frequency for each mode (or an approximation +C of it). The (generalized) Hessenberg form of the system is used. +C +C First, determine the maximum singular value of G(0) and set FPEAK +C accordingly. +C Additional workspace: +C complex: need 1, if DICO = 'C'; +C (N+M)*(N+P)+2*MIN(P,M)+MAX(P,M)), otherwise; +C prefer larger; +C real: need LDW0+LDW1+LDW2, where +C LDW0 = N*N+N*M, if DICO = 'C'; +C LDW0 = 0, if DICO = 'D'; +C LDW1 = P*M, if DICO = 'C', JOBD = 'Z'; +C LDW1 = 0, otherwise; +C LDW2 = MIN(P,M)+MAX(3*MIN(P,M)+MAX(P,M), +C 5*MIN(P,M)), +C if DICO = 'C'; +C LDW2 = 6*MIN(P,M), otherwise. +C prefer larger. +C + IF ( DISCR ) THEN + IAS = IA + IBS = IB + IWRK = IAR + N + ELSE + IAS = IAR + N + IBS = IAS + NN + IWRK = IBS + N*M + CALL DLACPY( 'Upper', N, N, DWORK( IA ), N, DWORK( IAS ), N ) + CALL DCOPY( N-1, DWORK( IA+1 ), N+1, DWORK( IAS+1 ), N+1 ) + CALL DLACPY( 'Full', N, M, DWORK( IB ), N, DWORK( IBS ), N ) + END IF + GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, ZERO, DWORK( IAS ), N, + $ DWORK( IE ), N, DWORK( IBS ), N, DWORK( IC ), P, + $ DWORK( ID ), P, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, CWORK, LCWORK, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) + IF( IERR.GE.1 .AND. IERR.LE.N ) THEN + GPEAK( 1 ) = ONE + FPEAK( 1 ) = ZERO + GPEAK( 2 ) = ZERO + FPEAK( 2 ) = ONE + GO TO 340 + ELSE IF( IERR.EQ.N+1 ) THEN + INFO = 3 + RETURN + END IF +C + FPEAKS = FPEAK( 1 ) + FPEAKI = FPEAK( 2 ) + IF( GAMMAL.LT.GAMMA ) THEN + GAMMAL = GAMMA + FPEAK( 1 ) = ZERO + FPEAK( 2 ) = ONE + ELSE IF( .NOT.DISCR ) THEN + FPEAK( 1 ) = ONE + FPEAK( 2 ) = ZERO + END IF +C + MAXCWK = INT( CWORK( 1 ) ) +C + IF( DISCR ) THEN +C +C Try the frequency w = pi. +C + PI = FOUR*ATAN( ONE ) + GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, PI, DWORK( IA ), + $ N, DWORK( IE ), N, DWORK( IB ), N, DWORK( IC ), + $ P, DWORK( ID ), P, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, CWORK, LCWORK, IERR ) + MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) + IF( IERR.GE.1 .AND. IERR.LE.N ) THEN + GPEAK( 1 ) = ONE + FPEAK( 1 ) = PI + GPEAK( 2 ) = ZERO + FPEAK( 2 ) = ONE + GO TO 340 + ELSE IF( IERR.EQ.N+1 ) THEN + INFO = 3 + RETURN + END IF +C + IF( GAMMAL.LT.GAMMA ) THEN + GAMMAL = GAMMA + FPEAK( 1 ) = PI + FPEAK( 2 ) = ONE + END IF +C + ELSE + IWRK = IAS +C +C Restore D, if needed. +C + IF ( WITHD ) + $ CALL DLACPY( 'Full', P, M, D, LDD, DWORK( ID ), P ) + END IF +C +C Build the remaining set of frequencies. +C Complex workspace: need (N+M)*(N+P)+2*MIN(P,M)+MAX(P,M)); +C prefer larger. +C Real workspace: need LDW2, see above; +C prefer larger. +C + IF ( MIN( FPEAKS, FPEAKI ).NE.ZERO ) THEN +C +C Compute also the norm at the given (finite) frequency. +C + GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, FPEAKS, DWORK( IA ), + $ N, DWORK( IE ), N, DWORK( IB ), N, DWORK( IC ), + $ P, DWORK( ID ), P, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, CWORK, LCWORK, IERR ) + MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) + IF ( DISCR ) THEN + TM = ABS( ATAN2( SIN( FPEAKS ), COS( FPEAKS ) ) ) + ELSE + TM = FPEAKS + END IF + IF( IERR.GE.1 .AND. IERR.LE.N ) THEN + GPEAK( 1 ) = ONE + FPEAK( 1 ) = TM + GPEAK( 2 ) = ZERO + FPEAK( 2 ) = ONE + GO TO 340 + ELSE IF( IERR.EQ.N+1 ) THEN + INFO = 3 + RETURN + END IF +C + IF( GAMMAL.LT.GAMMA ) THEN + GAMMAL = GAMMA + FPEAK( 1 ) = TM + FPEAK( 2 ) = ONE + END IF +C + END IF +C + DO 110 I = 0, N - 1 + IF( DWORK( II+I ).GE.ZERO .AND. DWORK( IM+I ).GT.ZERO ) THEN + IF ( ( DWORK( IM+I ).GE.ONE ) .OR. ( DWORK( IM+I ).LT.ONE + $ .AND. DWORK( IAR+I ).LT.SAFMAX*DWORK( IM+I ) ) ) THEN + RAT = DWORK( IAR+I ) / DWORK( IM+I ) + ELSE + RAT = ONE + END IF + OMEGA = DWORK( IM+I )*SQRT( MAX( P25, ONE - TWO*RAT**2 ) ) +C + GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, OMEGA, + $ DWORK( IA ), N, DWORK( IE ), N, DWORK( IB ), + $ N, DWORK( IC ), P, DWORK( ID ), P, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, CWORK, LCWORK, + $ IERR ) + MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) + IF ( DISCR ) THEN + TM = ABS( ATAN2( SIN( OMEGA ), COS( OMEGA ) ) ) + ELSE + TM = OMEGA + END IF + IF( IERR.GE.1 .AND. IERR.LE.N ) THEN + GPEAK( 1 ) = ONE + FPEAK( 1 ) = TM + GPEAK( 2 ) = ZERO + FPEAK( 2 ) = ONE + GO TO 340 + ELSE IF( IERR.EQ.N+1 ) THEN + INFO = 3 + RETURN + END IF +C + IF( GAMMAL.LT.GAMMA ) THEN + GAMMAL = GAMMA + FPEAK( 1 ) = TM + FPEAK( 2 ) = ONE + END IF +C + END IF + 110 CONTINUE +C +C Return if the lower bound is zero. +C + IF( GAMMAL.EQ.ZERO ) THEN + GPEAK( 1 ) = ZERO + FPEAK( 1 ) = ZERO + GPEAK( 2 ) = ONE + FPEAK( 2 ) = ONE + GO TO 340 + END IF +C +C Start the modified gamma iteration for the Bruinsma-Steinbuch +C algorithm. +C + IF ( .NOT.DISCR ) + $ RTOL = HUNDRD*TOLER + ITER = 0 +C +C WHILE ( Iteration may continue ) DO +C + 120 CONTINUE +C + ITER = ITER + 1 + GAMMA = ( ONE + TOL )*GAMMAL + USEPEN = FULLE .OR. DISCR + IF ( .NOT.USEPEN .AND. WITHD ) THEN +C +C Check whether one can use an explicit Hamiltonian matrix: +C compute +C min(rcond(GAMMA**2*Im - S'*S), rcond(GAMMA**2*Ip - S*S')). +C If P = M = 1, then GAMMA**2 - S(1)**2 is used instead. +C + IF ( M.NE.P ) THEN + RCOND = ONE - ( DWORK( IS ) / GAMMA )**2 + ELSE IF ( MINPM.GT.1 ) THEN + RCOND = ( GAMMA**2 - DWORK( IS )**2 ) / + $ ( GAMMA**2 - DWORK( IS+P-1 )**2 ) + ELSE + RCOND = GAMMA**2 - DWORK( IS )**2 + END IF +C + USEPEN = RCOND.LT.RTOL + END IF +C + IF ( USEPEN ) THEN +C +C Use the QZ algorithm on a pencil. +C Additional workspace here: need 6*N. (from IR) +C + II = IR + N2 + IBT = II + N2 + IH12 = IBT + N2 + IM = IH12 +C +C Set up the needed parts of the Hamiltonian pencil (H,J), +C +C ( H11 H12 ) +C H = ( ) , +C ( H21 H22 ) +C +C with +C +C ( A 0 ) ( 0 B ) ( E 0 ) +C H11 = ( ), H12 = ( )/nB, J11 = ( ), +C ( 0 -A' ) ( C' 0 ) ( 0 E' ) +C +C ( C 0 ) ( Ip D/g ) +C H21 = ( )*nB, H22 = ( ), +C ( 0 -B' ) ( D'/g Im ) +C +C if DICO = 'C', and +C +C ( A 0 ) ( B 0 ) ( E 0 ) +C H11 = ( ), H12 = ( )/nB, J11 = ( ), +C ( 0 E' ) ( 0 C' ) ( 0 A') +C +C ( 0 0 ) ( Im D'/g ) ( 0 B') +C H21 = ( )*nB, H22 = ( ), J21 = ( )*nB, +C ( C 0 ) ( D/g Ip ) ( 0 0 ) +C +C if DICO = 'D', where g = GAMMA, and nB = norm(B,1). +C First build [H12; H22]. +C + TEMP( 1 ) = ZERO + IH = IH12 +C + IF ( DISCR ) THEN +C + DO 150 J = 1, M +C + DO 130 I = 1, N + DWORK( IH ) = B( I, J ) / BNORM + IH = IH + 1 + 130 CONTINUE +C + CALL DCOPY( N+M, TEMP, 0, DWORK( IH ), 1 ) + DWORK( IH+N+J-1 ) = ONE + IH = IH + N + M +C + DO 140 I = 1, P + DWORK( IH ) = D( I, J ) / GAMMA + IH = IH + 1 + 140 CONTINUE +C + 150 CONTINUE +C + DO 180 J = 1, P + CALL DCOPY( N, TEMP, 0, DWORK( IH ), 1 ) + IH = IH + N +C + DO 160 I = 1, N + DWORK( IH ) = C( J, I ) / BNORM + IH = IH + 1 + 160 CONTINUE +C + DO 170 I = 1, M + DWORK( IH ) = D( J, I ) / GAMMA + IH = IH + 1 + 170 CONTINUE +C + CALL DCOPY( P, TEMP, 0, DWORK( IH ), 1 ) + DWORK( IH+J-1 ) = ONE + IH = IH + P + 180 CONTINUE +C + ELSE +C + DO 210 J = 1, P + CALL DCOPY( N, TEMP, 0, DWORK( IH ), 1 ) + IH = IH + N +C + DO 190 I = 1, N + DWORK( IH ) = C( J, I ) / BNORM + IH = IH + 1 + 190 CONTINUE +C + CALL DCOPY( P, TEMP, 0, DWORK( IH ), 1 ) + DWORK( IH+J-1 ) = ONE + IH = IH + P +C + DO 200 I = 1, M + DWORK( IH ) = D( J, I ) / GAMMA + IH = IH + 1 + 200 CONTINUE +C + 210 CONTINUE +C + DO 240 J = 1, M +C + DO 220 I = 1, N + DWORK( IH ) = B( I, J ) / BNORM + IH = IH + 1 + 220 CONTINUE +C + CALL DCOPY( N, TEMP, 0, DWORK( IH ), 1 ) + IH = IH + N +C + DO 230 I = 1, P + DWORK( IH ) = D( I, J ) / GAMMA + IH = IH + 1 + 230 CONTINUE +C + CALL DCOPY( M, TEMP, 0, DWORK( IH ), 1 ) + DWORK( IH+J-1 ) = ONE + IH = IH + M + 240 CONTINUE +C + END IF +C +C Compute the QR factorization of [H12; H22]. +C For large P and M, it could be more efficient to exploit the +C structure of [H12; H22] and use the factored form of Q. +C Additional workspace: need (2*N+P+M)*(2*N+P+M)+2*(P+M); +C prefer (2*N+P+M)*(2*N+P+M)+P+M+ +C (P+M)*NB. +C + ITAU = IH12 + N2PM*N2PM + IWRK = ITAU + PM + CALL DGEQRF( N2PM, PM, DWORK( IH12 ), N2PM, DWORK( ITAU ), + $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Apply part of the orthogonal transformation: +C Q1 = Q(:,P+M+(1:2*N))' to the matrix [H11; H21/GAMMA]. +C If DICO = 'C', apply Q(1:2*N,P+M+(1:2*N))' to the +C matrix J11. +C If DICO = 'D', apply Q1 to the matrix [J11; J21/GAMMA]. +C H11, H21, J11, and J21 are not fully built. +C First, build the (2*N+P+M)-by-(2*N+P+M) matrix Q. +C Using Q will often provide better efficiency than the direct +C use of the factored form of Q, especially when P+M < N. +C Additional workspace: need P+M+2*N+P+M; +C prefer P+M+(2*N+P+M)*NB. +C + CALL DORGQR( N2PM, N2PM, PM, DWORK( IH12 ), N2PM, + $ DWORK( ITAU ), DWORK( IWRK ), LDWORK-IWRK+1, + $ IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Additional workspace: need 8*N*N. +C + IPA = ITAU + IPE = IPA + 4*NN + IWRK = IPE + 4*NN + CALL DGEMM( 'Transpose', 'No Transpose', N2, N, N, ONE, + $ DWORK( IH12+PM*N2PM ), N2PM, A, LDA, ZERO, + $ DWORK( IPA ), N2 ) + IF ( DISCR ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', N2, N, P, + $ BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2+M), N2PM, + $ C, LDC, ONE, DWORK( IPA ), N2 ) + IF ( FULLE ) THEN + CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, ONE, + $ DWORK( IH12+PM*N2PM+N ), N2PM, E, LDE, + $ ZERO, DWORK( IPA+2*NN ), N2 ) + ELSE + CALL MA02AD( 'Full', N, N2, DWORK( IH12+PM*N2PM+N ), + $ N2PM, DWORK( IPA+2*NN ), N2 ) + NY = N + END IF + ELSE + CALL DGEMM( 'Transpose', 'No Transpose', N2, N, P, + $ BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2), N2PM, + $ C, LDC, ONE, DWORK( IPA ), N2 ) + CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, -ONE, + $ DWORK( IH12+PM*N2PM+N ), N2PM, A, LDA, ZERO, + $ DWORK( IPA+2*NN ), N2 ) + CALL DGEMM( 'Transpose', 'Transpose', N2, N, M, + $ -BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2+P), + $ N2PM, B, LDB, ONE, DWORK( IPA+2*NN ), N2 ) + NY = N2 + END IF +C + IF ( FULLE ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', N2, N, N, ONE, + $ DWORK( IH12+PM*N2PM ), N2PM, E, LDE, ZERO, + $ DWORK( IPE ), N2 ) + ELSE + CALL MA02AD( 'Full', NY, N2, DWORK( IH12+PM*N2PM ), + $ N2PM, DWORK( IPE ), N2 ) + END IF + IF ( DISCR ) THEN + CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, ONE, + $ DWORK( IH12+PM*N2PM+N ), N2PM, A, LDA, + $ ZERO, DWORK( IPE+... [truncated message content] |
From: <par...@us...> - 2009-12-01 21:30:19
|
Revision: 6567 http://octave.svn.sourceforge.net/octave/?rev=6567&view=rev Author: paramaniac Date: 2009-12-01 21:30:07 +0000 (Tue, 01 Dec 2009) Log Message: ----------- control-oo: delete folder ocst Modified Paths: -------------- trunk/octave-forge/extra/control-oo/PKG_ADD Removed Paths: ------------- trunk/octave-forge/extra/control-oo/inst/ocst/ Modified: trunk/octave-forge/extra/control-oo/PKG_ADD =================================================================== --- trunk/octave-forge/extra/control-oo/PKG_ADD 2009-12-01 21:25:26 UTC (rev 6566) +++ trunk/octave-forge/extra/control-oo/PKG_ADD 2009-12-01 21:30:07 UTC (rev 6567) @@ -1,3 +1,2 @@ addpath(fullfile (fileparts (mfilename ("fullpath")), "control")); -addpath(fullfile (fileparts (mfilename ("fullpath")), "ocst")); addpath(fullfile (fileparts (mfilename ("fullpath")), "examples")); \ No newline at end of file This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <par...@us...> - 2009-12-02 13:42:43
|
Revision: 6577 http://octave.svn.sourceforge.net/octave/?rev=6577&view=rev Author: paramaniac Date: 2009-12-02 13:42:30 +0000 (Wed, 02 Dec 2009) Log Message: ----------- control-oo: delete PKG_ADD Modified Paths: -------------- trunk/octave-forge/extra/control-oo/Makefile Removed Paths: ------------- trunk/octave-forge/extra/control-oo/PKG_ADD Modified: trunk/octave-forge/extra/control-oo/Makefile =================================================================== --- trunk/octave-forge/extra/control-oo/Makefile 2009-12-02 13:39:43 UTC (rev 6576) +++ trunk/octave-forge/extra/control-oo/Makefile 2009-12-02 13:42:30 UTC (rev 6577) @@ -1,6 +1,6 @@ sinclude ../../Makeconf -PKG_FILES = COPYING DESCRIPTION INDEX PKG_ADD $(wildcard inst/*) +PKG_FILES = COPYING DESCRIPTION INDEX $(wildcard inst/*) SUBDIRS = doc/ .PHONY: $(SUBDIRS) Deleted: trunk/octave-forge/extra/control-oo/PKG_ADD =================================================================== --- trunk/octave-forge/extra/control-oo/PKG_ADD 2009-12-02 13:39:43 UTC (rev 6576) +++ trunk/octave-forge/extra/control-oo/PKG_ADD 2009-12-02 13:42:30 UTC (rev 6577) @@ -1,2 +0,0 @@ -addpath(fullfile (fileparts (mfilename ("fullpath")), "control")); -addpath(fullfile (fileparts (mfilename ("fullpath")), "examples")); \ No newline at end of file This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <par...@us...> - 2009-12-03 12:05:04
|
Revision: 6584 http://octave.svn.sourceforge.net/octave/?rev=6584&view=rev Author: paramaniac Date: 2009-12-03 12:04:50 +0000 (Thu, 03 Dec 2009) Log Message: ----------- control-oo: add h2syn (test included) Modified Paths: -------------- trunk/octave-forge/extra/control-oo/INDEX trunk/octave-forge/extra/control-oo/src/Makefile Added Paths: ----------- trunk/octave-forge/extra/control-oo/inst/h2syn.m trunk/octave-forge/extra/control-oo/src/MA02ED.f trunk/octave-forge/extra/control-oo/src/MB01RU.f trunk/octave-forge/extra/control-oo/src/MB01RX.f trunk/octave-forge/extra/control-oo/src/MB01RY.f trunk/octave-forge/extra/control-oo/src/MB01UD.f trunk/octave-forge/extra/control-oo/src/MB02PD.f trunk/octave-forge/extra/control-oo/src/SB02MR.f trunk/octave-forge/extra/control-oo/src/SB02MS.f trunk/octave-forge/extra/control-oo/src/SB02MV.f trunk/octave-forge/extra/control-oo/src/SB02MW.f trunk/octave-forge/extra/control-oo/src/SB02OD.f trunk/octave-forge/extra/control-oo/src/SB02OU.f trunk/octave-forge/extra/control-oo/src/SB02OV.f trunk/octave-forge/extra/control-oo/src/SB02OW.f trunk/octave-forge/extra/control-oo/src/SB02OY.f trunk/octave-forge/extra/control-oo/src/SB02QD.f trunk/octave-forge/extra/control-oo/src/SB02RD.f trunk/octave-forge/extra/control-oo/src/SB02RU.f trunk/octave-forge/extra/control-oo/src/SB02SD.f trunk/octave-forge/extra/control-oo/src/SB03MV.f trunk/octave-forge/extra/control-oo/src/SB03MW.f trunk/octave-forge/extra/control-oo/src/SB03MX.f trunk/octave-forge/extra/control-oo/src/SB03MY.f trunk/octave-forge/extra/control-oo/src/SB03QX.f trunk/octave-forge/extra/control-oo/src/SB03QY.f trunk/octave-forge/extra/control-oo/src/SB03SX.f trunk/octave-forge/extra/control-oo/src/SB03SY.f trunk/octave-forge/extra/control-oo/src/SB04PX.f trunk/octave-forge/extra/control-oo/src/SB10ED.f trunk/octave-forge/extra/control-oo/src/SB10HD.f trunk/octave-forge/extra/control-oo/src/SB10PD.f trunk/octave-forge/extra/control-oo/src/SB10SD.f trunk/octave-forge/extra/control-oo/src/SB10TD.f trunk/octave-forge/extra/control-oo/src/SB10UD.f trunk/octave-forge/extra/control-oo/src/SB10VD.f trunk/octave-forge/extra/control-oo/src/SB10WD.f Modified: trunk/octave-forge/extra/control-oo/INDEX =================================================================== --- trunk/octave-forge/extra/control-oo/INDEX 2009-12-03 11:30:26 UTC (rev 6583) +++ trunk/octave-forge/extra/control-oo/INDEX 2009-12-03 12:04:50 UTC (rev 6584) @@ -51,6 +51,7 @@ kalman lqr Controller Synthesis + h2syn State-Space Models ctrb gram Added: trunk/octave-forge/extra/control-oo/inst/h2syn.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/h2syn.m (rev 0) +++ trunk/octave-forge/extra/control-oo/inst/h2syn.m 2009-12-03 12:04:50 UTC (rev 6584) @@ -0,0 +1,203 @@ +## Copyright (C) 2009 Lukas F. Reichlin +## +## This file is part of LTI Syncope. +## +## LTI Syncope 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. +## +## LTI Syncope 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, see <http://www.gnu.org/licenses/>. + +## -*- texinfo -*- +## @deftypefn{Function File} {[@var{K}, @var{T}, @var{gamma}] =} h2syn (@var{P}, @var{nmeas}, @var{ncon}) +## H2 control synthesis for LTI plant. +## Uses SLICOT SB10HD and SB10ED by courtesy of NICONET e.V. +## <http://www.slicot.org> +## @end deftypefn + +## Author: Lukas Reichlin <luk...@gm...> +## Created: December 2009 +## Version: 0.1 + +function [K, varargout] = h2syn (P, nmeas, ncon) + + ## check input arguments + if (nargin != 3) + print_usage (); + endif + + if (! isa (P, "lti")) + error ("h2syn: first argument must be a LTI system"); + endif + + if (! isscalar (nmeas) || ! isnumeric (nmeas) || isempty (nmeas)) + error ("h2syn: second argument invalid"); + endif + + if (! isscalar (ncon) || ! isnumeric (ncon) || isempty (ncon)) + error ("h2syn: third argument invalid"); + endif + + [a, b, c, d, tsam] = ssdata (P); + + ## check assumptions A1 - A3 + m = columns (b); + p = rows (c); + + m1 = m - ncon; + p1 = p - nmeas; + + d11 = d(1:p1, 1:m1); + + if (tsam <= 0 && ! all (all (d11 == 0))) + error ("h2syn: matrice D11 must be zero"); + endif + + if (! isstabilizable (P(:, m1+1 : m))) + error ("h2syn: (A, B2) must be stabilizable"); + endif + + if (! isdetectable (P(p1+1 : p, :))) + error ("h2syn: (A, C2) must be detectable"); + endif + + ## H-2 synthesis + if (tsam > 0) # discrete plant + [ak, bk, ck, dk] = slsb10ed (a, b, c, d, ncon, nmeas); + else # continuous plant + [ak, bk, ck, dk] = slsb10hd (a, b, c, d, ncon, nmeas); + endif + + ## controller + K = ss (ak, bk, ck, dk, tsam); + + if (nargout > 1) + T = lft (P, K); + varargout{1} = T; + if (nargout > 2) + varargout{2} = norm (T); + endif + endif + +endfunction + + +## continuous-time case +%!shared M, M_exp +%! A = [-1.0 0.0 4.0 5.0 -3.0 -2.0 +%! -2.0 4.0 -7.0 -2.0 0.0 3.0 +%! -6.0 9.0 -5.0 0.0 2.0 -1.0 +%! -8.0 4.0 7.0 -1.0 -3.0 0.0 +%! 2.0 5.0 8.0 -9.0 1.0 -4.0 +%! 3.0 -5.0 8.0 0.0 2.0 -6.0]; +%! +%! B = [-3.0 -4.0 -2.0 1.0 0.0 +%! 2.0 0.0 1.0 -5.0 2.0 +%! -5.0 -7.0 0.0 7.0 -2.0 +%! 4.0 -6.0 1.0 1.0 -2.0 +%! -3.0 9.0 -8.0 0.0 5.0 +%! 1.0 -2.0 3.0 -6.0 -2.0]; +%! +%! C = [ 1.0 -1.0 2.0 -4.0 0.0 -3.0 +%! -3.0 0.0 5.0 -1.0 1.0 1.0 +%! -7.0 5.0 0.0 -8.0 2.0 -2.0 +%! 9.0 -3.0 4.0 0.0 3.0 7.0 +%! 0.0 1.0 -2.0 1.0 -6.0 -2.0]; +%! +%! D = [ 0.0 0.0 0.0 -4.0 -1.0 +%! 0.0 0.0 0.0 1.0 0.0 +%! 0.0 0.0 0.0 0.0 1.0 +%! 3.0 1.0 0.0 1.0 -3.0 +%! -2.0 0.0 1.0 7.0 1.0]; +%! +%! P = ss (A, B, C, D); +%! K = h2syn (P, 2, 2); +%! M = [K.A, K.B; K.C, K.D]; +%! +%! KA = [ 88.0015 -145.7298 -46.2424 82.2168 -45.2996 -31.1407 +%! 25.7489 -31.4642 -12.4198 9.4625 -3.5182 2.7056 +%! 54.3008 -102.4013 -41.4968 50.8412 -20.1286 -26.7191 +%! 108.1006 -198.0785 -45.4333 70.3962 -25.8591 -37.2741 +%! -115.8900 226.1843 47.2549 -47.8435 -12.5004 34.7474 +%! 59.0362 -101.8471 -20.1052 36.7834 -16.1063 -26.4309]; +%! +%! KB = [ 3.7345 3.4758 +%! -0.3020 0.6530 +%! 3.4735 4.0499 +%! 4.3198 7.2755 +%! -3.9424 -10.5942 +%! 2.1784 2.5048]; +%! +%! KC = [ -2.3346 3.2556 0.7150 -0.9724 0.6962 0.4074 +%! 7.6899 -8.4558 -2.9642 7.0365 -4.2844 0.1390]; +%! +%! KD = [ 0.0000 0.0000 +%! 0.0000 0.0000]; +%! +%! M_exp = [KA, KB; KC, KD]; +%! +%!assert (M, M_exp, 1e-4); + + +## discrete-time case +%!shared M, M_exp +%! A = [-0.7 0.0 0.3 0.0 -0.5 -0.1 +%! -0.6 0.2 -0.4 -0.3 0.0 0.0 +%! -0.5 0.7 -0.1 0.0 0.0 -0.8 +%! -0.7 0.0 0.0 -0.5 -1.0 0.0 +%! 0.0 0.3 0.6 -0.9 0.1 -0.4 +%! 0.5 -0.8 0.0 0.0 0.2 -0.9]; +%! +%! B = [-1.0 -2.0 -2.0 1.0 0.0 +%! 1.0 0.0 1.0 -2.0 1.0 +%! -3.0 -4.0 0.0 2.0 -2.0 +%! 1.0 -2.0 1.0 0.0 -1.0 +%! 0.0 1.0 -2.0 0.0 3.0 +%! 1.0 0.0 3.0 -1.0 -2.0]; +%! +%! C = [ 1.0 -1.0 2.0 -2.0 0.0 -3.0 +%! -3.0 0.0 1.0 -1.0 1.0 0.0 +%! 0.0 2.0 0.0 -4.0 0.0 -2.0 +%! 1.0 -3.0 0.0 0.0 3.0 1.0 +%! 0.0 1.0 -2.0 1.0 0.0 -2.0]; +%! +%! D = [ 1.0 -1.0 -2.0 0.0 0.0 +%! 0.0 1.0 0.0 1.0 0.0 +%! 2.0 -1.0 -3.0 0.0 1.0 +%! 0.0 1.0 0.0 1.0 -1.0 +%! 0.0 0.0 1.0 2.0 1.0]; +%! +%! P = ss (A, B, C, D, 1); # value of sampling time doesn't matter +%! K = h2syn (P, 2, 2); +%! M = [K.A, K.B; K.C, K.D]; +%! +%! KA = [-0.0551 -2.1891 -0.6607 -0.2532 0.6674 -1.0044 +%! -1.0379 2.3804 0.5031 0.3960 -0.6605 1.2673 +%! -0.0876 -2.1320 -0.4701 -1.1461 1.2927 -1.5116 +%! -0.1358 -2.1237 -0.9560 -0.7144 0.6673 -0.7957 +%! 0.4900 0.0895 0.2634 -0.2354 0.1623 -0.2663 +%! 0.1672 -0.4163 0.2871 -0.1983 0.4944 -0.6967]; +%! +%! KB = [-0.5985 -0.5464 +%! 0.5285 0.6087 +%! -0.7600 -0.4472 +%! -0.7288 -0.6090 +%! 0.0532 0.0658 +%! -0.0663 0.0059]; +%! +%! KC = [ 0.2500 -1.0200 -0.3371 -0.2733 0.2747 -0.4444 +%! 0.0654 0.2095 0.0632 0.2089 -0.1895 0.1834]; +%! +%! KD = [-0.2181 -0.2070 +%! 0.1094 0.1159]; +%! +%! M_exp = [KA, KB; KC, KD]; +%! +%!assert (M, M_exp, 1e-4); \ No newline at end of file Added: trunk/octave-forge/extra/control-oo/src/MA02ED.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/MA02ED.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/MA02ED.f 2009-12-03 12:04:50 UTC (rev 6584) @@ -0,0 +1,99 @@ + SUBROUTINE MA02ED( UPLO, N, A, LDA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To store by symmetry the upper or lower triangle of a symmetric +C matrix, given the other triangle. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Specifies which part of the matrix is given as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part. +C For all other values, the array A is not referenced. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N upper triangular part +C (if UPLO = 'U'), or lower triangular part (if UPLO = 'L'), +C of this array must contain the corresponding upper or +C lower triangle of the symmetric matrix A. +C On exit, the leading N-by-N part of this array contains +C the symmetric matrix A with all elements stored. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Romania, +C Oct. 1998. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*) +C .. Local Scalars .. + INTEGER J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY +C +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked for errors. +C + IF( LSAME( UPLO, 'L' ) ) THEN +C +C Construct the upper triangle of A. +C + DO 20 J = 2, N + CALL DCOPY( J-1, A(J,1), LDA, A(1,J), 1 ) + 20 CONTINUE +C + ELSE IF( LSAME( UPLO, 'U' ) ) THEN +C +C Construct the lower triangle of A. +C + DO 40 J = 2, N + CALL DCOPY( J-1, A(1,J), 1, A(J,1), LDA ) + 40 CONTINUE +C + END IF + RETURN +C *** Last line of MA02ED *** + END Added: trunk/octave-forge/extra/control-oo/src/MB01RU.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/MB01RU.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/MB01RU.f 2009-12-03 12:04:50 UTC (rev 6584) @@ -0,0 +1,282 @@ + SUBROUTINE MB01RU( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA, + $ X, LDX, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To compute the matrix formula +C _ +C R = alpha*R + beta*op( A )*X*op( A )', +C _ +C where alpha and beta are scalars, R, X, and R are symmetric +C matrices, A is a general matrix, and op( A ) is one of +C +C op( A ) = A or op( A ) = A'. +C +C The result is overwritten on R. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Specifies which triangles of the symmetric matrices R +C and X are given as follows: +C = 'U': the upper triangular part is given; +C = 'L': the lower triangular part is given. +C +C TRANS CHARACTER*1 +C Specifies the form of op( A ) to be used in the matrix +C multiplication as follows: +C = 'N': op( A ) = A; +C = 'T': op( A ) = A'; +C = 'C': op( A ) = A'. +C +C Input/Output Parameters +C +C M (input) INTEGER _ +C The order of the matrices R and R and the number of rows +C of the matrix op( A ). M >= 0. +C +C N (input) INTEGER +C The order of the matrix X and the number of columns of the +C the matrix op( A ). N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then R need not be +C set before entry, except when R is identified with X in +C the call. +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then A and X are not +C referenced. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) +C On entry with UPLO = 'U', the leading M-by-M upper +C triangular part of this array must contain the upper +C triangular part of the symmetric matrix R. +C On entry with UPLO = 'L', the leading M-by-M lower +C triangular part of this array must contain the lower +C triangular part of the symmetric matrix R. +C On exit, the leading M-by-M upper triangular part (if +C UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of +C this array contains the corresponding triangular part of +C _ +C the computed matrix R. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,M). +C +C A (input) DOUBLE PRECISION array, dimension (LDA,k) +C where k is N when TRANS = 'N' and is M when TRANS = 'T' or +C TRANS = 'C'. +C On entry with TRANS = 'N', the leading M-by-N part of this +C array must contain the matrix A. +C On entry with TRANS = 'T' or TRANS = 'C', the leading +C N-by-M part of this array must contain the matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,k), +C where k is M when TRANS = 'N' and is N when TRANS = 'T' or +C TRANS = 'C'. +C +C X (input) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, if UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular part of the symmetric matrix X and the strictly +C lower triangular part of the array is not referenced. +C On entry, if UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular part of the symmetric matrix X and the strictly +C upper triangular part of the array is not referenced. +C The diagonal elements of this array are modified +C internally, but are restored on exit. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= MAX(1,N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C This array is not referenced when beta = 0, or M*N = 0. +C +C LDWORK The length of the array DWORK. +C LDWORK >= M*N, if beta <> 0; +C LDWORK >= 0, if beta = 0. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -k, the k-th argument had an illegal +C value. +C +C METHOD +C +C The matrix expression is efficiently evaluated taking the symmetry +C into account. Specifically, let X = T + T', with T an upper or +C lower triangular matrix, defined by +C +C T = triu( X ) - (1/2)*diag( X ), if UPLO = 'U', +C T = tril( X ) - (1/2)*diag( X ), if UPLO = 'L', +C +C where triu, tril, and diag denote the upper triangular part, lower +C triangular part, and diagonal part of X, respectively. Then, +C +C A*X*A' = ( A*T )*A' + A*( A*T )', for TRANS = 'N', +C A'*X*A = A'*( T*A ) + ( T*A )'*A, for TRANS = 'T', or 'C', +C +C which involve BLAS 3 operations (DTRMM and DSYR2K). +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately +C +C 2 2 +C 3/2 x M x N + 1/2 x M +C +C operations. +C +C FURTHER COMMENTS +C +C This is a simpler version for MB01RD. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1999. +C +C REVISIONS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2004. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, HALF + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ HALF = 0.5D0 ) +C .. Scalar Arguments .. + CHARACTER TRANS, UPLO + INTEGER INFO, LDA, LDR, LDWORK, LDX, M, N + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), R(LDR,*), X(LDX,*) +C .. Local Scalars .. + LOGICAL LTRANS, LUPLO +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, DLASCL, DLASET, DSCAL, DSYR2K, DTRMM, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LUPLO = LSAME( UPLO, 'U' ) + LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN + INFO = -1 + ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDR.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDA.LT.1 .OR. ( LTRANS .AND. LDA.LT.N ) .OR. + $ ( .NOT.LTRANS .AND. LDA.LT.M ) ) THEN + INFO = -10 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( ( BETA.NE.ZERO .AND. LDWORK.LT.M*N ) + $ .OR.( BETA.EQ.ZERO .AND. LDWORK.LT.0 ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01RU', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN + IF ( ALPHA.EQ.ZERO ) THEN +C +C Special case alpha = 0. +C + CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) + ELSE +C +C Special case beta = 0 or N = 0. +C + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) + END IF + RETURN + END IF +C +C General case: beta <> 0. +C Compute W = op( A )*T or W = T*op( A ) in DWORK, and apply the +C updating formula (see METHOD section). +C Workspace: need M*N. +C + CALL DSCAL( N, HALF, X, LDX+1 ) +C + IF( LTRANS ) THEN +C + CALL DLACPY( 'Full', N, M, A, LDA, DWORK, N ) + CALL DTRMM( 'Left', UPLO, 'NoTranspose', 'Non-unit', N, M, + $ ONE, X, LDX, DWORK, N ) + CALL DSYR2K( UPLO, TRANS, M, N, BETA, DWORK, N, A, LDA, ALPHA, + $ R, LDR ) +C + ELSE +C + CALL DLACPY( 'Full', M, N, A, LDA, DWORK, M ) + CALL DTRMM( 'Right', UPLO, 'NoTranspose', 'Non-unit', M, N, + $ ONE, X, LDX, DWORK, M ) + CALL DSYR2K( UPLO, TRANS, M, N, BETA, DWORK, M, A, LDA, ALPHA, + $ R, LDR ) +C + END IF +C + CALL DSCAL( N, TWO, X, LDX+1 ) +C + RETURN +C *** Last line of MB01RU *** + END Added: trunk/octave-forge/extra/control-oo/src/MB01RX.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/MB01RX.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/MB01RX.f 2009-12-03 12:04:50 UTC (rev 6584) @@ -0,0 +1,315 @@ + SUBROUTINE MB01RX( SIDE, UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, + $ A, LDA, B, LDB, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To compute either the upper or lower triangular part of one of the +C matrix formulas +C _ +C R = alpha*R + beta*op( A )*B, (1) +C _ +C R = alpha*R + beta*B*op( A ), (2) +C _ +C where alpha and beta are scalars, R and R are m-by-m matrices, +C op( A ) and B are m-by-n and n-by-m matrices for (1), or n-by-m +C and m-by-n matrices for (2), respectively, and op( A ) is one of +C +C op( A ) = A or op( A ) = A', the transpose of A. +C +C The result is overwritten on R. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies whether the matrix A appears on the left or +C right in the matrix product as follows: +C _ +C = 'L': R = alpha*R + beta*op( A )*B; +C _ +C = 'R': R = alpha*R + beta*B*op( A ). +C +C UPLO CHARACTER*1 _ +C Specifies which triangles of the matrices R and R are +C computed and given, respectively, as follows: +C = 'U': the upper triangular part; +C = 'L': the lower triangular part. +C +C TRANS CHARACTER*1 +C Specifies the form of op( A ) to be used in the matrix +C multiplication as follows: +C = 'N': op( A ) = A; +C = 'T': op( A ) = A'; +C = 'C': op( A ) = A'. +C +C Input/Output Parameters +C +C M (input) INTEGER _ +C The order of the matrices R and R, the number of rows of +C the matrix op( A ) and the number of columns of the +C matrix B, for SIDE = 'L', or the number of rows of the +C matrix B and the number of columns of the matrix op( A ), +C for SIDE = 'R'. M >= 0. +C +C N (input) INTEGER +C The number of rows of the matrix B and the number of +C columns of the matrix op( A ), for SIDE = 'L', or the +C number of rows of the matrix op( A ) and the number of +C columns of the matrix B, for SIDE = 'R'. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then R need not be +C set before entry. +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then A and B are not +C referenced. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) +C On entry with UPLO = 'U', the leading M-by-M upper +C triangular part of this array must contain the upper +C triangular part of the matrix R; the strictly lower +C triangular part of the array is not referenced. +C On entry with UPLO = 'L', the leading M-by-M lower +C triangular part of this array must contain the lower +C triangular part of the matrix R; the strictly upper +C triangular part of the array is not referenced. +C On exit, the leading M-by-M upper triangular part (if +C UPLO = 'U'), or lower triangular part (if UPLO = 'L') of +C this array contains the corresponding triangular part of +C _ +C the computed matrix R. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,M). +C +C A (input) DOUBLE PRECISION array, dimension (LDA,k), where +C k = N when SIDE = 'L', and TRANS = 'N', or +C SIDE = 'R', and TRANS = 'T'; +C k = M when SIDE = 'R', and TRANS = 'N', or +C SIDE = 'L', and TRANS = 'T'. +C On entry, if SIDE = 'L', and TRANS = 'N', or +C SIDE = 'R', and TRANS = 'T', +C the leading M-by-N part of this array must contain the +C matrix A. +C On entry, if SIDE = 'R', and TRANS = 'N', or +C SIDE = 'L', and TRANS = 'T', +C the leading N-by-M part of this array must contain the +C matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,l), where +C l = M when SIDE = 'L', and TRANS = 'N', or +C SIDE = 'R', and TRANS = 'T'; +C l = N when SIDE = 'R', and TRANS = 'N', or +C SIDE = 'L', and TRANS = 'T'. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,p), where +C p = M when SIDE = 'L'; +C p = N when SIDE = 'R'. +C On entry, the leading N-by-M part, if SIDE = 'L', or +C M-by-N part, if SIDE = 'R', of this array must contain the +C matrix B. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,N), if SIDE = 'L'; +C LDB >= MAX(1,M), if SIDE = 'R'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix expression is evaluated taking the triangular +C structure into account. BLAS 2 operations are used. A block +C algorithm can be easily constructed; it can use BLAS 3 GEMM +C operations for most computations, and calls of this BLAS 2 +C algorithm for computing the triangles. +C +C FURTHER COMMENTS +C +C The main application of this routine is when the result should +C be a symmetric matrix, e.g., when B = X*op( A )', for (1), or +C B = op( A )'*X, for (2), where B is already available and X = X'. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER SIDE, TRANS, UPLO + INTEGER INFO, LDA, LDB, LDR, M, N + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), R(LDR,*) +C .. Local Scalars .. + LOGICAL LSIDE, LTRANS, LUPLO + INTEGER J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEMV, DLASCL, DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LSIDE = LSAME( SIDE, 'L' ) + LUPLO = LSAME( UPLO, 'U' ) + LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN + INFO = -1 + ELSE IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN + INFO = -2 + ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDR.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.1 .OR. + $ ( ( ( LSIDE .AND. .NOT.LTRANS ) .OR. + $ ( .NOT.LSIDE .AND. LTRANS ) ) .AND. LDA.LT.M ) .OR. + $ ( ( ( LSIDE .AND. LTRANS ) .OR. + $ ( .NOT.LSIDE .AND. .NOT.LTRANS ) ) .AND. LDA.LT.N ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.1 .OR. + $ ( LSIDE .AND. LDB.LT.N ) .OR. + $ ( .NOT.LSIDE .AND. LDB.LT.M ) ) THEN + INFO = -13 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01RX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN + IF ( ALPHA.EQ.ZERO ) THEN +C +C Special case alpha = 0. +C + CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) + ELSE +C +C Special case beta = 0 or N = 0. +C + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) + END IF + RETURN + END IF +C +C General case: beta <> 0. +C Compute the required triangle of (1) or (2) using BLAS 2 +C operations. +C + IF( LSIDE ) THEN + IF( LUPLO ) THEN + IF ( LTRANS ) THEN + DO 10 J = 1, M + CALL DGEMV( TRANS, N, J, BETA, A, LDA, B(1,J), 1, + $ ALPHA, R(1,J), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, M + CALL DGEMV( TRANS, J, N, BETA, A, LDA, B(1,J), 1, + $ ALPHA, R(1,J), 1 ) + 20 CONTINUE + END IF + ELSE + IF ( LTRANS ) THEN + DO 30 J = 1, M + CALL DGEMV( TRANS, N, M-J+1, BETA, A(1,J), LDA, + $ B(1,J), 1, ALPHA, R(J,J), 1 ) + 30 CONTINUE + ELSE + DO 40 J = 1, M + CALL DGEMV( TRANS, M-J+1, N, BETA, A(J,1), LDA, + $ B(1,J), 1, ALPHA, R(J,J), 1 ) + 40 CONTINUE + END IF + END IF +C + ELSE + IF( LUPLO ) THEN + IF( LTRANS ) THEN + DO 50 J = 1, M + CALL DGEMV( 'NoTranspose', J, N, BETA, B, LDB, A(J,1), + $ LDA, ALPHA, R(1,J), 1 ) + 50 CONTINUE + ELSE + DO 60 J = 1, M + CALL DGEMV( 'NoTranspose', J, N, BETA, B, LDB, A(1,J), + $ 1, ALPHA, R(1,J), 1 ) + 60 CONTINUE + END IF + ELSE + IF( LTRANS ) THEN + DO 70 J = 1, M + CALL DGEMV( 'NoTranspose', M-J+1, N, BETA, B(J,1), + $ LDB, A(J,1), LDA, ALPHA, R(J,J), 1 ) + 70 CONTINUE + ELSE + DO 80 J = 1, M + CALL DGEMV( 'NoTranspose', M-J+1, N, BETA, B(J,1), + $ LDB, A(1,J), 1, ALPHA, R(J,J), 1 ) + 80 CONTINUE + END IF + END IF + END IF +C + RETURN +C *** Last line of MB01RX *** + END Added: trunk/octave-forge/extra/control-oo/src/MB01RY.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/MB01RY.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/MB01RY.f 2009-12-03 12:04:50 UTC (rev 6584) @@ -0,0 +1,429 @@ + SUBROUTINE MB01RY( SIDE, UPLO, TRANS, M, ALPHA, BETA, R, LDR, H, + $ LDH, B, LDB, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To compute either the upper or lower triangular part of one of the +C matrix formulas +C _ +C R = alpha*R + beta*op( H )*B, (1) +C _ +C R = alpha*R + beta*B*op( H ), (2) +C _ +C where alpha and beta are scalars, H, B, R, and R are m-by-m +C matrices, H is an upper Hessenberg matrix, and op( H ) is one of +C +C op( H ) = H or op( H ) = H', the transpose of H. +C +C The result is overwritten on R. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies whether the Hessenberg matrix H appears on the +C left or right in the matrix product as follows: +C _ +C = 'L': R = alpha*R + beta*op( H )*B; +C _ +C = 'R': R = alpha*R + beta*B*op( H ). +C +C UPLO CHARACTER*1 _ +C Specifies which triangles of the matrices R and R are +C computed and given, respectively, as follows: +C = 'U': the upper triangular part; +C = 'L': the lower triangular part. +C +C TRANS CHARACTER*1 +C Specifies the form of op( H ) to be used in the matrix +C multiplication as follows: +C = 'N': op( H ) = H; +C = 'T': op( H ) = H'; +C = 'C': op( H ) = H'. +C +C Input/Output Parameters +C +C M (input) INTEGER _ +C The order of the matrices R, R, H and B. M >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then R need not be +C set before entry. +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then H and B are not +C referenced. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) +C On entry with UPLO = 'U', the leading M-by-M upper +C triangular part of this array must contain the upper +C triangular part of the matrix R; the strictly lower +C triangular part of the array is not referenced. +C On entry with UPLO = 'L', the leading M-by-M lower +C triangular part of this array must contain the lower +C triangular part of the matrix R; the strictly upper +C triangular part of the array is not referenced. +C On exit, the leading M-by-M upper triangular part (if +C UPLO = 'U'), or lower triangular part (if UPLO = 'L') of +C this array contains the corresponding triangular part of +C _ +C the computed matrix R. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,M). +C +C H (input) DOUBLE PRECISION array, dimension (LDH,M) +C On entry, the leading M-by-M upper Hessenberg part of +C this array must contain the upper Hessenberg part of the +C matrix H. +C The elements below the subdiagonal are not referenced, +C except possibly for those in the first column, which +C could be overwritten, but are restored on exit. +C +C LDH INTEGER +C The leading dimension of array H. LDH >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading M-by-M part of this array must +C contain the matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C LDWORK >= M, if beta <> 0 and SIDE = 'L'; +C LDWORK >= 0, if beta = 0 or SIDE = 'R'. +C This array is not referenced when beta = 0 or SIDE = 'R'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix expression is efficiently evaluated taking the +C Hessenberg/triangular structure into account. BLAS 2 operations +C are used. A block algorithm can be constructed; it can use BLAS 3 +C GEMM operations for most computations, and calls of this BLAS 2 +C algorithm for computing the triangles. +C +C FURTHER COMMENTS +C +C The main application of this routine is when the result should +C be a symmetric matrix, e.g., when B = X*op( H )', for (1), or +C B = op( H )'*X, for (2), where B is already available and X = X'. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER SIDE, TRANS, UPLO + INTEGER INFO, LDB, LDH, LDR, M + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION B(LDB,*), DWORK(*), H(LDH,*), R(LDR,*) +C .. Local Scalars .. + LOGICAL LSIDE, LTRANS, LUPLO + INTEGER I, J +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL DDOT, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DLASCL, DLASET, DSCAL, DSWAP, + $ DTRMV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LSIDE = LSAME( SIDE, 'L' ) + LUPLO = LSAME( UPLO, 'U' ) + LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN + INFO = -1 + ELSE IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN + INFO = -2 + ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( LDR.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDH.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01RY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + IF ( BETA.EQ.ZERO ) THEN + IF ( ALPHA.EQ.ZERO ) THEN +C +C Special case when both alpha = 0 and beta = 0. +C + CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) + ELSE +C +C Special case beta = 0. +C + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) + END IF + RETURN + END IF +C +C General case: beta <> 0. +C Compute the required triangle of (1) or (2) using BLAS 2 +C operations. +C + IF( LSIDE ) THEN +C +C To avoid repeated references to the subdiagonal elements of H, +C these are swapped with the corresponding elements of H in the +C first column, and are finally restored. +C + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) +C + IF( LUPLO ) THEN + IF ( LTRANS ) THEN +C + DO 20 J = 1, M +C +C Multiply the transposed upper triangle of the leading +C j-by-j submatrix of H by the leading part of the j-th +C column of B. +C + CALL DCOPY( J, B( 1, J ), 1, DWORK, 1 ) + CALL DTRMV( 'Upper', TRANS, 'Non-unit', J, H, LDH, + $ DWORK, 1 ) +C +C Add the contribution of the subdiagonal of H to +C the j-th column of the product. +C + DO 10 I = 1, MIN( J, M - 1 ) + R( I, J ) = ALPHA*R( I, J ) + BETA*( DWORK( I ) + + $ H( I+1, 1 )*B( I+1, J ) ) + 10 CONTINUE +C + 20 CONTINUE +C + R( M, M ) = ALPHA*R( M, M ) + BETA*DWORK( M ) +C + ELSE +C + DO 40 J = 1, M +C +C Multiply the upper triangle of the leading j-by-j +C submatrix of H by the leading part of the j-th column +C of B. +C + CALL DCOPY( J, B( 1, J ), 1, DWORK, 1 ) + CALL DTRMV( 'Upper', TRANS, 'Non-unit', J, H, LDH, + $ DWORK, 1 ) + IF( J.LT.M ) THEN +C +C Multiply the remaining right part of the leading +C j-by-M submatrix of H by the trailing part of the +C j-th column of B. +C + CALL DGEMV( TRANS, J, M-J, BETA, H( 1, J+1 ), LDH, + $ B( J+1, J ), 1, ALPHA, R( 1, J ), 1 ) + ELSE + CALL DSCAL( M, ALPHA, R( 1, M ), 1 ) + END IF +C +C Add the contribution of the subdiagonal of H to +C the j-th column of the product. +C + R( 1, J ) = R( 1, J ) + BETA*DWORK( 1 ) +C + DO 30 I = 2, J + R( I, J ) = R( I, J ) + BETA*( DWORK( I ) + + $ H( I, 1 )*B( I-1, J ) ) + 30 CONTINUE +C + 40 CONTINUE +C + END IF +C + ELSE +C + IF ( LTRANS ) THEN +C + DO 60 J = M, 1, -1 +C +C Multiply the transposed upper triangle of the trailing +C (M-j+1)-by-(M-j+1) submatrix of H by the trailing part +C of the j-th column of B. +C + CALL DCOPY( M-J+1, B( J, J ), 1, DWORK( J ), 1 ) + CALL DTRMV( 'Upper', TRANS, 'Non-unit', M-J+1, + $ H( J, J ), LDH, DWORK( J ), 1 ) + IF( J.GT.1 ) THEN +C +C Multiply the remaining left part of the trailing +C (M-j+1)-by-(j-1) submatrix of H' by the leading +C part of the j-th column of B. +C + CALL DGEMV( TRANS, J-1, M-J+1, BETA, H( 1, J ), + $ LDH, B( 1, J ), 1, ALPHA, R( J, J ), + $ 1 ) + ELSE + CALL DSCAL( M, ALPHA, R( 1, 1 ), 1 ) + END IF +C +C Add the contribution of the subdiagonal of H to +C the j-th column of the product. +C + DO 50 I = J, M - 1 + R( I, J ) = R( I, J ) + BETA*( DWORK( I ) + + $ H( I+1, 1 )*B( I+1, J ) ) + 50 CONTINUE +C + R( M, J ) = R( M, J ) + BETA*DWORK( M ) + 60 CONTINUE +C + ELSE +C + DO 80 J = M, 1, -1 +C +C Multiply the upper triangle of the trailing +C (M-j+1)-by-(M-j+1) submatrix of H by the trailing +C part of the j-th column of B. +C + CALL DCOPY( M-J+1, B( J, J ), 1, DWORK( J ), 1 ) + CALL DTRMV( 'Upper', TRANS, 'Non-unit', M-J+1, + $ H( J, J ), LDH, DWORK( J ), 1 ) +C +C Add the contribution of the subdiagonal of H to +C the j-th column of the product. +C + DO 70 I = MAX( J, 2 ), M + R( I, J ) = ALPHA*R( I, J ) + BETA*( DWORK( I ) + $ + H( I, 1 )*B( I-1, J ) ) + 70 CONTINUE +C + 80 CONTINUE +C + R( 1, 1 ) = ALPHA*R( 1, 1 ) + BETA*DWORK( 1 ) +C + END IF + END IF +C + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) +C + ELSE +C +C Row-wise calculations are used for H, if SIDE = 'R' and +C TRANS = 'T'. +C + IF( LUPLO ) THEN + IF( LTRANS ) THEN + R( 1, 1 ) = ALPHA*R( 1, 1 ) + + $ BETA*DDOT( M, B, LDB, H, LDH ) +C + DO 90 J = 2, M + CALL DGEMV( 'NoTranspose', J, M-J+2, BETA, + $ B( 1, J-1 ), LDB, H( J, J-1 ), LDH, + $ ALPHA, R( 1, J ), 1 ) + 90 CONTINUE +C + ELSE +C + DO 100 J = 1, M - 1 + CALL DGEMV( 'NoTranspose', J, J+1, BETA, B, LDB, + $ H( 1, J ), 1, ALPHA, R( 1, J ), 1 ) + 100 CONTINUE +C + CALL DGEMV( 'NoTranspose', M, M, BETA, B, LDB, + $ H( 1, M ), 1, ALPHA, R( 1, M ), 1 ) +C + END IF +C + ELSE +C + IF( LTRANS ) THEN +C + CALL DGEMV( 'NoTranspose', M, M, BETA, B, LDB, H, LDH, + $ ALPHA, R( 1, 1 ), 1 ) +C + DO 110 J = 2, M + CALL DGEMV( 'NoTranspose', M-J+1, M-J+2, BETA, + $ B( J, J-1 ), LDB, H( J, J-1 ), LDH, ALPHA, + $ R( J, J ), 1 ) + 110 CONTINUE +C + ELSE +C + DO 120 J = 1, M - 1 + CALL DGEMV( 'NoTranspose', M-J+1, J+1, BETA, + $ B( J, 1 ), LDB, H( 1, J ), 1, ALPHA, + $ R( J, J ), 1 ) + 120 CONTINUE +C + R( M, M ) = ALPHA*R( M, M ) + + $ BETA*DDOT( M, B( M, 1 ), LDB, H( 1, M ), 1 ) +C + END IF + END IF + END IF +C + RETURN +C *** Last line of MB01RY *** + END Added: trunk/octave-forge/extra/control-oo/src/MB01UD.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/MB01UD.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/MB01UD.f 2009-12-03 12:04:50 UTC (rev 6584) @@ -0,0 +1,238 @@ + SUBROUTINE MB01UD( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA, B, + $ LDB, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To compute one of the matrix products +C +C B = alpha*op( H ) * A, or B = alpha*A * op( H ), +C +C where alpha is a scalar, A and B are m-by-n matrices, H is an +C upper Hessenberg matrix, and op( H ) is one of +C +C op( H ) = H or op( H ) = H', the transpose of H. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies whether the Hessenberg matrix H appears on the +C left or right in the matrix product as follows: +C = 'L': B = alpha*op( H ) * A; +C = 'R': B = alpha*A * op( H ). +C +C TRANS CHARACTER*1 +C Specifies the form of op( H ) to be used in the matrix +C multiplication as follows: +C = 'N': op( H ) = H; +C = 'T': op( H ) = H'; +C = 'C': op( H ) = H'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices A and B. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrices A and B. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then H is not +C referenced and A need not be set before entry. +C +C H (input) DOUBLE PRECISION array, dimension (LDH,k) +C where k is M when SIDE = 'L' and is N when SIDE = 'R'. +C On entry with SIDE = 'L', the leading M-by-M upper +C Hessenberg part of this array must contain the upper +C Hessenberg matrix H. +C On entry with SIDE = 'R', the leading N-by-N upper +C Hessenberg part of this array must contain the upper +C Hessenberg matrix H. +C The elements below the subdiagonal are not referenced, +C except possibly for those in the first column, which +C could be overwritten, but are restored on exit. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,k), +C where k is M when SIDE = 'L' and is N when SIDE = 'R'. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading M-by-N part of this array must contain the +C matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,N) +C The leading M-by-N part of this array contains the +C computed product. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The required matrix product is computed in two steps. In the first +C step, the upper triangle of H is used; in the second step, the +C contribution of the subdiagonal is added. A fast BLAS 3 DTRMM +C operation is used in the first step. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, January 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, LDB, LDH, M, N + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), H(LDH,*) +C .. Local Scalars .. + LOGICAL LSIDE, LTRANS + INTEGER I, J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DLACPY, DLASET, DSWAP, DTRMM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LSIDE = LSAME( SIDE, 'L' ) + LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN + INFO = -1 + ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDH.LT.1 .OR. ( LSIDE .AND. LDH.LT.M ) .OR. + $ ( .NOT.LSIDE .AND. LDH.LT.N ) ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01UD', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + IF ( MIN( M, N ).EQ.0 ) + $ RETURN +C + IF( ALPHA.EQ.ZERO ) THEN +C +C Set B to zero and return. +C + CALL DLASET( 'Full', M, N, ZERO, ZERO, B, LDB ) + RETURN + END IF +C +C Copy A in B and compute one of the matrix products +C B = alpha*op( triu( H ) ) * A, or +C B = alpha*A * op( triu( H ) ), +C involving the upper triangle of H. +C + CALL DLACPY( 'Full', M, N, A, LDA, B, LDB ) + CALL DTRMM( SIDE, 'Upper', TRANS, 'Non-unit', M, N, ALPHA, H, + $ LDH, B, LDB ) +C +C Add the contribution of the subdiagonal of H. +C If SIDE = 'L', the subdiagonal of H is swapped with the +C corresponding elements in the first column of H, and the +C calculations are organized for column operations. +C + IF( LSIDE ) THEN + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) + IF( LTRANS ) THEN + DO 20 J = 1, N + DO 10 I = 1, M - 1 + B( I, J ) = B( I, J ) + ALPHA*H( I+1, 1 )*A( I+1, J ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = 2, M + B( I, J ) = B( I, J ) + ALPHA*H( I, 1 )*A( I-1, J ) + 30 CONTINUE + 40 CONTINUE + END IF + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) +C + ELSE +C + IF( LTRANS ) THEN + DO 50 J = 1, N - 1 + IF ( H( J+1, J ).NE.ZERO ) + $ CALL DAXPY( M, ALPHA*H( J+1, J ), A( 1, J ), 1, + $ B( 1, J+1 ), 1 ) + 50 CONTINUE + ELSE + DO 60 J = 1, N - 1 + IF ( H( J+1, J ).NE.ZERO ) + $ CALL DAXPY( M, ALPHA*H( J+1, J ), A( 1, J+1 ), 1, + $ B( 1, J ), 1 ) + 60 CONTINUE + END IF + END IF +C + RETURN +C *** Last line of MB01UD *** + END Added: trunk/octave-forge/extra/control-oo/src/MB02PD.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/MB02PD.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/MB02PD.f 2009-12-03 12:04:50 UTC (rev 6584) @@ -0,0 +1,553 @@ + SUBROUTINE MB02PD( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, + $ IWORK, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To solve (if well-conditioned) the matrix equations +C +C op( A )*X = B, +C +C where X and B are N-by-NRHS matrices, A is an N-by-N matrix and +C op( A ) is one of +C +C op( A ) = A or op( A ) = A'. +C +C Error bounds on the solution and a condition estimate are also +C provided. +C +C ARGUMENTS +C +C Mode Parameters +C +C FACT CHARACTER*1 +C Specifies whether or not the factored form of the matrix A +C is supplied on entry, and if not, whether the matrix A +C should be equilibrated before it is factored. +C = 'F': On entry, AF and IPIV contain the factored form +C of A. If EQUED is not 'N', the matrix A has been +C equilibrated with scaling factors given by R +C and C. A, AF, and IPIV are not modified. +C = 'N': The matrix A will be copied to AF and factored. +C ... [truncated message content] |
From: <par...@us...> - 2009-12-04 04:46:26
|
Revision: 6593 http://octave.svn.sourceforge.net/octave/?rev=6593&view=rev Author: paramaniac Date: 2009-12-04 04:46:15 +0000 (Fri, 04 Dec 2009) Log Message: ----------- control-oo: add H-2 norm (SLICOT AB13BD) Modified Paths: -------------- trunk/octave-forge/extra/control-oo/inst/@lti/norm.m trunk/octave-forge/extra/control-oo/src/Makefile Added Paths: ----------- trunk/octave-forge/extra/control-oo/src/AB13BD.f trunk/octave-forge/extra/control-oo/src/MB03QD.f trunk/octave-forge/extra/control-oo/src/MB03QX.f trunk/octave-forge/extra/control-oo/src/MB03QY.f trunk/octave-forge/extra/control-oo/src/MB04ND.f trunk/octave-forge/extra/control-oo/src/MB04NY.f trunk/octave-forge/extra/control-oo/src/MB04OD.f trunk/octave-forge/extra/control-oo/src/MB04OX.f trunk/octave-forge/extra/control-oo/src/MB04OY.f trunk/octave-forge/extra/control-oo/src/SB01FY.f trunk/octave-forge/extra/control-oo/src/SB03OR.f trunk/octave-forge/extra/control-oo/src/SB03OT.f trunk/octave-forge/extra/control-oo/src/SB03OU.f trunk/octave-forge/extra/control-oo/src/SB03OV.f trunk/octave-forge/extra/control-oo/src/SB03OY.f trunk/octave-forge/extra/control-oo/src/SB08DD.f trunk/octave-forge/extra/control-oo/src/TB01LD.f trunk/octave-forge/extra/control-oo/src/slab13bd.cc Modified: trunk/octave-forge/extra/control-oo/inst/@lti/norm.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/@lti/norm.m 2009-12-03 15:56:38 UTC (rev 6592) +++ trunk/octave-forge/extra/control-oo/inst/@lti/norm.m 2009-12-04 04:46:15 UTC (rev 6593) @@ -1,38 +1,33 @@ -## Copyright (C) 1996, 1998, 2000, 2002, 2004, 2005, 2006, 2007 -## Auburn University. All rights reserved. +## Copyright (C) 2009 Lukas F. Reichlin ## +## This file is part of LTI Syncope. ## -## 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. +## LTI Syncope 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. +## LTI Syncope 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; see the file COPYING. If not, see -## <http://www.gnu.org/licenses/>. +## along with this program. If not, see <http://www.gnu.org/licenses/>. ## -*- texinfo -*- ## @deftypefn {Function File} {@var{gain} =} norm (@var{sys}, @var{2}) ## @deftypefnx {Function File} {@var{gain}, @var{wpeak} =} norm (@var{sys}, @var{inf}) ## @deftypefnx {Function File} {@var{gain}, @var{wpeak} =} norm (@var{sys}, @var{inf}, @var{tol}) -## Return norm of LTI model. L-infinity norm uses SLICOT AB13DD. +## Return H-2 or L-inf norm of LTI model. +## Uses SLICOT AB13BD and AB13DD by courtesy of NICONET e.V. +## <http://www.slicot.org> ## @end deftypefn -## Author: A. S. Hodel <a.s...@en...> -## Created: August 1995 -## Reference: Doyle, Glover, Khargonekar, Francis -## State-Space Solutions to Standard Control Problems -## IEEE TAC August 1989 +## Author: Lukas Reichlin <luk...@gm...> +## Created: November 2009 +## Version: 0.2 -## Adapted-By: Lukas Reichlin <luk...@gm...> -## Date: November 2009 -## Version: 0.1 - function [gain, varargout] = norm (sys, ntype = "2", tol = 0.01) if (nargin > 3) # norm () is caught by built-in function @@ -70,22 +65,19 @@ function gain = h2norm (sys) if (isstable (sys)) - [a, b, c, d] = ssdata (sys); - - if (isct (sys)) - M = lyap (a, b*b'); + [a, b, c, d, tsam] = ssdata (sys); + + if (tsam <= 0 && ! all (all (d == 0))) # continuous and non-zero feedthrough + gain = inf; else - M = dlyap (a, b*b'); + [gain, iwarn] = slab13bd (a, b, c, d, tsam); + + if (iwarn) + warning ("lti: norm: slab13bd: iwarn = %d", iwarn); + endif endif - - if (min (real (eig (M))) < 0) - error ("norm: H2: gramian < 0 (lightly damped modes?)") - endif - - gain = sqrt (trace (d*d' + c*M*c')); else - warning ("norm: H2: unstable input system; returning Inf"); - gain = Inf; + gain = inf; endif endfunction Added: trunk/octave-forge/extra/control-oo/src/AB13BD.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/AB13BD.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/AB13BD.f 2009-12-04 04:46:15 UTC (rev 6593) @@ -0,0 +1,390 @@ + DOUBLE PRECISION FUNCTION AB13BD( DICO, JOBN, N, M, P, A, LDA, + $ B, LDB, C, LDC, D, LDD, NQ, TOL, + $ DWORK, LDWORK, IWARN, INFO) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To compute the H2 or L2 norm of the transfer-function matrix G +C of the system (A,B,C,D). G must not have poles on the imaginary +C axis, for a continuous-time system, or on the unit circle, for +C a discrete-time system. If the H2-norm is computed, the system +C must be stable. +C +C FUNCTION VALUE +C +C AB13BD DOUBLE PRECISION +C The H2-norm of G, if JOBN = 'H', or the L2-norm of G, +C if JOBN = 'L' (if INFO = 0). +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBN CHARACTER*1 +C Specifies the norm to be computed as follows: +C = 'H': the H2-norm; +C = 'L': the L2-norm. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A, the number of rows of the +C matrix B, and the number of columns of the matrix C. +C N represents the dimension of the state vector. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrices B and D. +C M represents the dimension of input vector. M >= 0. +C +C P (input) INTEGER +C The number of rows of the matrices C and D. +C P represents the dimension of output vector. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix of the system. +C On exit, the leading NQ-by-NQ part of this array contains +C the state dynamics matrix (in a real Schur form) of the +C numerator factor Q of the right coprime factorization with +C inner denominator of G (see METHOD). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix of the system. +C On exit, the leading NQ-by-M part of this array contains +C the input/state matrix of the numerator factor Q of the +C right coprime factorization with inner denominator of G +C (see METHOD). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix of the system. +C On exit, the leading P-by-NQ part of this array contains +C the state/output matrix of the numerator factor Q of the +C right coprime factorization with inner denominator of G +C (see METHOD). +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the input/output matrix of the system. +C If DICO = 'C', D must be a null matrix. +C On exit, the leading P-by-M part of this array contains +C the input/output matrix of the numerator factor Q of +C the right coprime factorization with inner denominator +C of G (see METHOD). +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NQ (output) INTEGER +C The order of the resulting numerator Q of the right +C coprime factorization with inner denominator of G (see +C METHOD). +C Generally, NQ = N - NS, where NS is the number of +C uncontrollable unstable eigenvalues. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The absolute tolerance level below which the elements of +C B are considered zero (used for controllability tests). +C If the user sets TOL <= 0, then an implicitly computed, +C default tolerance, defined by TOLDEF = N*EPS*NORM(B), +C is used instead, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH) and NORM(B) denotes +C the 1-norm of B. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. +C LDWORK >= MAX( 1, M*(N+M) + MAX( N*(N+5), M*(M+2), 4*P ), +C N*( MAX( N, P ) + 4 ) + MIN( N, P ) ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = K: K violations of the numerical stability condition +C occured during the assignment of eigenvalues in +C computing the right coprime factorization with inner +C denominator of G (see the SLICOT subroutine SB08DD). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to a real Schur form failed; +C = 2: a failure was detected during the reordering of the +C real Schur form of A, or in the iterative process +C for reordering the eigenvalues of Z'*(A + B*F)*Z +C along the diagonal (see SLICOT routine SB08DD); +C = 3: if DICO = 'C' and the matrix A has a controllable +C eigenvalue on the imaginary axis, or DICO = 'D' +C and A has a controllable eigenvalue on the unit +C circle; +C = 4: the solution of Lyapunov equation failed because +C the equation is singular; +C = 5: if DICO = 'C' and D is a nonzero matrix; +C = 6: if JOBN = 'H' and the system is unstable. +C +C METHOD +C +C The subroutine is based on the algorithms proposed in [1] and [2]. +C +C If the given transfer-function matrix G is unstable, then a right +C coprime factorization with inner denominator of G is first +C computed +C -1 +C G = Q*R , +C +C where Q and R are stable transfer-function matrices and R is +C inner. If G is stable, then Q = G and R = I. +C Let (AQ,BQ,CQ,DQ) be the state-space representation of Q. +C +C If DICO = 'C', then the L2-norm of G is computed as +C +C NORM2(G) = NORM2(Q) = SQRT(TRACE(BQ'*X*BQ)), +C +C where X satisfies the continuous-time Lyapunov equation +C +C AQ'*X + X*AQ + CQ'*CQ = 0. +C +C If DICO = 'D', then the l2-norm of G is computed as +C +C NORM2(G) = NORM2(Q) = SQRT(TRACE(BQ'*X*BQ+DQ'*DQ)), +C +C where X satisfies the discrete-time Lyapunov equation +C +C AQ'*X*AQ - X + CQ'*CQ = 0. +C +C REFERENCES +C +C [1] Varga A. +C On computing 2-norms of transfer-function matrices. +C Proc. 1992 ACC, Chicago, June 1992. +C +C [2] Varga A. +C A Schur method for computing coprime factorizations with +C inner denominators and applications in model reduction. +C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires no more than 14N floating point +C operations. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine SL2NRM. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. +C Jan. 2003, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C Coprime factorization, Lyapunov equation, multivariable system, +C state-space model, system norms. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOBN + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, M, + $ N, NQ, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) +C .. Local Scalars .. + LOGICAL DISCR + INTEGER KCR, KDR, KRW, KTAU, KU, MXNP, NR + DOUBLE PRECISION S2NORM, SCALE, WRKOPT +C .. External functions .. + LOGICAL LSAME + DOUBLE PRECISION DLANGE, DLAPY2 + EXTERNAL DLANGE, DLAPY2, LSAME +C .. External subroutines .. + EXTERNAL DLACPY, DTRMM, SB03OU, SB08DD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + DISCR = LSAME( DICO, 'D' ) + INFO = 0 + IWARN = 0 +C +C Check the scalar input parameters. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( JOBN, 'H' ) .OR. LSAME( JOBN, 'L' ) ) ) + $ THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDWORK.LT.MAX( 1, M*( N + M ) + + $ MAX( N*( N + 5 ), M*( M + 2 ), 4*P ), + $ N*( MAX( N, P ) + 4 ) + MIN( N, P ) ) ) + $ THEN + INFO = -17 + END IF + IF( INFO.NE.0 )THEN +C +C Error return. +C + CALL XERBLA( 'AB13BD', -INFO ) + RETURN + END IF +C +C Compute the Frobenius norm of D. +C + S2NORM = DLANGE( 'Frobenius', P, M, D, LDD, DWORK ) + IF( .NOT.DISCR .AND. S2NORM.NE.ZERO ) THEN + INFO = 5 + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NQ = 0 + AB13BD = ZERO + DWORK(1) = ONE + RETURN + END IF +C + KCR = 1 + KDR = KCR + M*N + KRW = KDR + M*M +C +C Compute the right coprime factorization with inner denominator +C of G. +C +C Workspace needed: M*(N+M); +C Additional workspace: need MAX( N*(N+5), M*(M+2), 4*M, 4*P ); +C prefer larger. +C + CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, NQ, + $ NR, DWORK(KCR), M, DWORK(KDR), M, TOL, DWORK(KRW), + $ LDWORK-KRW+1, IWARN, INFO ) + IF( INFO.NE.0 ) + $ RETURN +C + WRKOPT = DWORK(KRW) + DBLE( KRW-1 ) +C +C Check stability. +C + IF( LSAME( JOBN, 'H' ) .AND. NR.GT.0 ) THEN + INFO = 6 + RETURN + END IF +C + IF( NQ.GT.0 ) THEN + KU = 1 + MXNP = MAX( NQ, P ) + KTAU = NQ*MXNP + 1 + KRW = KTAU + MIN( NQ, P ) +C +C Find X, the solution of Lyapunov equation. +C +C Workspace needed: N*MAX(N,P) + MIN(N,P); +C Additional workspace: 4*N; +C prefer larger. +C + CALL DLACPY( 'Full', P, NQ, C, LDC, DWORK(KU), MXNP ) + CALL SB03OU( DISCR, .FALSE., NQ, P, A, LDA, DWORK(KU), MXNP, + $ DWORK(KTAU), DWORK(KU), NQ, SCALE, DWORK(KRW), + $ LDWORK-KRW+1, INFO ) + IF( INFO.NE.0 ) THEN + IF( INFO.EQ.1 ) THEN + INFO = 4 + ELSE IF( INFO.EQ.2 ) THEN + INFO = 3 + END IF + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(KRW) + DBLE( KRW-1 ) ) +C +C Add the contribution of BQ'*X*BQ. +C +C Workspace needed: N*(N+M). +C + KTAU = NQ*NQ + 1 + CALL DLACPY( 'Full', NQ, M, B, LDB, DWORK(KTAU), NQ ) + CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', NQ, M, + $ ONE, DWORK(KU), NQ, DWORK(KTAU), NQ ) + IF( NR.GT.0 ) + $ S2NORM = DLANGE( 'Frobenius', P, M, D, LDD, DWORK ) + S2NORM = DLAPY2( S2NORM, DLANGE( 'Frobenius', NQ, M, + $ DWORK(KTAU), NQ, DWORK ) + $ / SCALE ) + END IF +C + AB13BD = S2NORM +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB13BD *** + END Added: trunk/octave-forge/extra/control-oo/src/MB03QD.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/MB03QD.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/MB03QD.f 2009-12-04 04:46:15 UTC (rev 6593) @@ -0,0 +1,316 @@ + SUBROUTINE MB03QD( DICO, STDOM, JOBU, N, NLOW, NSUP, ALPHA, + $ A, LDA, U, LDU, NDIM, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To reorder the diagonal blocks of a principal submatrix of an +C upper quasi-triangular matrix A together with their eigenvalues by +C constructing an orthogonal similarity transformation UT. +C After reordering, the leading block of the selected submatrix of A +C has eigenvalues in a suitably defined domain of interest, usually +C related to stability/instability in a continuous- or discrete-time +C sense. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the spectrum separation to be +C performed as follows: +C = 'C': continuous-time sense; +C = 'D': discrete-time sense. +C +C STDOM CHARACTER*1 +C Specifies whether the domain of interest is of stability +C type (left part of complex plane or inside of a circle) +C or of instability type (right part of complex plane or +C outside of a circle) as follows: +C = 'S': stability type domain; +C = 'U': instability type domain. +C +C JOBU CHARACTER*1 +C Indicates how the performed orthogonal transformations UT +C are accumulated, as follows: +C = 'I': U is initialized to the unit matrix and the matrix +C UT is returned in U; +C = 'U': the given matrix U is updated and the matrix U*UT +C is returned in U. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and U. N >= 1. +C +C NLOW, (input) INTEGER +C NSUP NLOW and NSUP specify the boundary indices for the rows +C and columns of the principal submatrix of A whose diagonal +C blocks are to be reordered. 1 <= NLOW <= NSUP <= N. +C +C ALPHA (input) DOUBLE PRECISION +C The boundary of the domain of interest for the eigenvalues +C of A. If DICO = 'C', ALPHA is the boundary value for the +C real parts of eigenvalues, while for DICO = 'D', +C ALPHA >= 0 represents the boundary value for the moduli of +C eigenvalues. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain a matrix in a real Schur form whose 1-by-1 and +C 2-by-2 diagonal blocks between positions NLOW and NSUP +C are to be reordered. +C On exit, the leading N-by-N part contains the ordered +C real Schur matrix UT' * A * UT with the elements below the +C first subdiagonal set to zero. +C The leading NDIM-by-NDIM part of the principal submatrix +C D = A(NLOW:NSUP,NLOW:NSUP) has eigenvalues in the domain +C of interest and the trailing part of this submatrix has +C eigenvalues outside the domain of interest. +C The domain of interest for lambda(D), the eigenvalues of +C D, is defined by the parameters ALPHA, DICO and STDOM as +C follows: +C For DICO = 'C': +C Real(lambda(D)) < ALPHA if STDOM = 'S'; +C Real(lambda(D)) > ALPHA if STDOM = 'U'. +C For DICO = 'D': +C Abs(lambda(D)) < ALPHA if STDOM = 'S'; +C Abs(lambda(D)) > ALPHA if STDOM = 'U'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) +C On entry with JOBU = 'U', the leading N-by-N part of this +C array must contain a transformation matrix (e.g. from a +C previous call to this routine). +C On exit, if JOBU = 'U', the leading N-by-N part of this +C array contains the product of the input matrix U and the +C orthogonal matrix UT used to reorder the diagonal blocks +C of A. +C On exit, if JOBU = 'I', the leading N-by-N part of this +C array contains the matrix UT of the performed orthogonal +C transformations. +C Array U need not be set on entry if JOBU = 'I'. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= N. +C +C NDIM (output) INTEGER +C The number of eigenvalues of the selected principal +C submatrix lying inside the domain of interest. +C If NLOW = 1, NDIM is also the dimension of the invariant +C subspace corresponding to the eigenvalues of the leading +C NDIM-by-NDIM submatrix. In this case, if U is the +C orthogonal transformation matrix used to compute and +C reorder the real Schur form of A, its first NDIM columns +C form an orthonormal basis for the above invariant +C subspace. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: A(NLOW,NLOW-1) is nonzero, i.e. A(NLOW,NLOW) is not +C the leading element of a 1-by-1 or 2-by-2 diagonal +C block of A, or A(NSUP+1,NSUP) is nonzero, i.e. +C A(NSUP,NSUP) is not the bottom element of a 1-by-1 +C or 2-by-2 diagonal block of A; +C = 2: two adjacent blocks are too close to swap (the +C problem is very ill-conditioned). +C +C METHOD +C +C Given an upper quasi-triangular matrix A with 1-by-1 or 2-by-2 +C diagonal blocks, the routine reorders its diagonal blocks along +C with its eigenvalues by performing an orthogonal similarity +C transformation UT' * A * UT. The column transformation UT is also +C performed on the given (initial) transformation U (resulted from +C a possible previous step or initialized as the identity matrix). +C After reordering, the eigenvalues inside the region specified by +C the parameters ALPHA, DICO and STDOM appear at the top of +C the selected diagonal block between positions NLOW and NSUP. +C In other words, lambda(A(NLOW:NSUP,NLOW:NSUP)) are ordered such +C that lambda(A(NLOW:NLOW+NDIM-1,NLOW:NLOW+NDIM-1)) are inside and +C lambda(A(NLOW+NDIM:NSUP,NLOW+NDIM:NSUP)) are outside the domain +C of interest. If NLOW = 1, the first NDIM columns of U*UT span the +C corresponding invariant subspace of A. +C +C REFERENCES +C +C [1] Stewart, G.W. +C HQR3 and EXCHQZ: FORTRAN subroutines for calculating and +C ordering the eigenvalues of a real upper Hessenberg matrix. +C ACM TOMS, 2, pp. 275-280, 1976. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires less than 4*N operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, +C April 1998. Based on the RASP routine SEOR1. +C +C KEYWORDS +C +C Eigenvalues, invariant subspace, orthogonal transformation, real +C Schur form, similarity transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOBU, STDOM + INTEGER INFO, LDA, LDU, N, NDIM, NLOW, NSUP + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), U(LDU,*) +C .. Local Scalars .. + LOGICAL DISCR, LSTDOM + INTEGER IB, L, LM1, NUP + DOUBLE PRECISION E1, E2, TLAMBD +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL DLASET, DTREXC, MB03QY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + LSTDOM = LSAME( STDOM, 'S' ) +C +C Check input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSTDOM .OR. LSAME( STDOM, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( JOBU, 'I' ) .OR. + $ LSAME( JOBU, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.1 ) THEN + INFO = -4 + ELSE IF( NLOW.LT.1 ) THEN + INFO = -5 + ELSE IF( NLOW.GT.NSUP .OR. NSUP.GT.N ) THEN + INFO = -6 + ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN + INFO = -7 + ELSE IF( LDA.LT.N ) THEN + INFO = -9 + ELSE IF( LDU.LT.N ) THEN + INFO = -11 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB03QD', -INFO ) + RETURN + END IF +C + IF( NLOW.GT.1 ) THEN + IF( A(NLOW,NLOW-1).NE.ZERO ) INFO = 1 + END IF + IF( NSUP.LT.N ) THEN + IF( A(NSUP+1,NSUP).NE.ZERO ) INFO = 1 + END IF + IF( INFO.NE.0 ) + $ RETURN +C +C Initialize U with an identity matrix if necessary. +C + IF( LSAME( JOBU, 'I' ) ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) +C + NDIM = 0 + L = NSUP + NUP = NSUP +C +C NUP is the minimal value such that the submatrix A(i,j) with +C NUP+1 <= i,j <= NSUP contains no eigenvalues inside the domain of +C interest. L is such that all the eigenvalues of the submatrix +C A(i,j) with L+1 <= i,j <= NUP lie inside the domain of interest. +C +C WHILE( L >= NLOW ) DO +C + 10 IF( L.GE.NLOW ) THEN + IB = 1 + IF( L.GT.NLOW ) THEN + LM1 = L - 1 + IF( A(L,LM1).NE.ZERO ) THEN + CALL MB03QY( N, LM1, A, LDA, U, LDU, E1, E2, INFO ) + IF( A(L,LM1).NE.ZERO ) IB = 2 + END IF + END IF + IF( DISCR ) THEN + IF( IB.EQ.1 ) THEN + TLAMBD = ABS( A(L,L) ) + ELSE + TLAMBD = DLAPY2( E1, E2 ) + END IF + ELSE + IF( IB.EQ.1 ) THEN + TLAMBD = A(L,L) + ELSE + TLAMBD = E1 + END IF + END IF + IF( ( LSTDOM .AND. TLAMBD.LT.ALPHA ) .OR. + $ ( .NOT.LSTDOM .AND. TLAMBD.GT.ALPHA ) ) THEN + NDIM = NDIM + IB + L = L - IB + ELSE + IF( NDIM.NE.0 ) THEN + CALL DTREXC( 'V', N, A, LDA, U, LDU, L, NUP, DWORK, + $ INFO ) + IF( INFO.NE.0 ) THEN + INFO = 2 + RETURN + END IF + NUP = NUP - 1 + L = L - 1 + ELSE + NUP = NUP - IB + L = L - IB + END IF + END IF + GO TO 10 + END IF +C +C END WHILE 10 +C + RETURN +C *** Last line of MB03QD *** + END Added: trunk/octave-forge/extra/control-oo/src/MB03QX.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/MB03QX.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/MB03QX.f 2009-12-04 04:46:15 UTC (rev 6593) @@ -0,0 +1,122 @@ + SUBROUTINE MB03QX( N, T, LDT, WR, WI, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To compute the eigenvalues of an upper quasi-triangular matrix. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix T. N >= 0. +C +C T (input) DOUBLE PRECISION array, dimension(LDT,N) +C The upper quasi-triangular matrix T. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= max(1,N). +C +C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) +C The real and imaginary parts, respectively, of the +C eigenvalues of T. The eigenvalues are stored in the same +C order as on the diagonal of T. If T(i:i+1,i:i+1) is a +C 2-by-2 diagonal block with complex conjugated eigenvalues +C then WI(i) > 0 and WI(i+1) = -WI(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, +C March 1998. Based on the RASP routine SEIG. +C +C ****************************************************************** +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDT, N +C .. Array Arguments .. + DOUBLE PRECISION T(LDT, *), WI(*), WR(*) +C .. Local Scalars .. + INTEGER I, I1, INEXT + DOUBLE PRECISION A11, A12, A21, A22, CS, SN +C .. External Subroutines .. + EXTERNAL DLANV2, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -3 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB03QX', -INFO ) + RETURN + END IF +C + INEXT = 1 + DO 10 I = 1, N + IF( I.LT.INEXT ) + $ GO TO 10 + IF( I.NE.N ) THEN + IF( T(I+1,I).NE.ZERO ) THEN +C +C A pair of eigenvalues. +C + INEXT = I + 2 + I1 = I + 1 + A11 = T(I,I) + A12 = T(I,I1) + A21 = T(I1,I) + A22 = T(I1,I1) + CALL DLANV2( A11, A12, A21, A22, WR(I), WI(I), WR(I1), + $ WI(I1), CS, SN ) + GO TO 10 + END IF + END IF +C +C Simple eigenvalue. +C + INEXT = I + 1 + WR(I) = T(I,I) + WI(I) = ZERO + 10 CONTINUE +C + RETURN +C *** Last line of MB03QX *** + END Added: trunk/octave-forge/extra/control-oo/src/MB03QY.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/MB03QY.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/MB03QY.f 2009-12-04 04:46:15 UTC (rev 6593) @@ -0,0 +1,164 @@ + SUBROUTINE MB03QY( N, L, A, LDA, U, LDU, E1, E2, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To compute the eigenvalues of a selected 2-by-2 diagonal block +C of an upper quasi-triangular matrix, to reduce the selected block +C to the standard form and to split the block in the case of real +C eigenvalues by constructing an orthogonal transformation UT. +C This transformation is applied to A (by similarity) and to +C another matrix U from the right. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and UT. N >= 2. +C +C L (input) INTEGER +C Specifies the position of the block. 1 <= L < N. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the upper quasi-triangular matrix A whose +C selected 2-by-2 diagonal block is to be processed. +C On exit, the leading N-by-N part of this array contains +C the upper quasi-triangular matrix A after its selected +C block has been splitt and/or put in the LAPACK standard +C form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) +C On entry, the leading N-by-N part of this array must +C contain a transformation matrix U. +C On exit, the leading N-by-N part of this array contains +C U*UT, where UT is the transformation matrix used to +C split and/or standardize the selected block. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= N. +C +C E1, E2 (output) DOUBLE PRECISION +C E1 and E2 contain either the real eigenvalues or the real +C and positive imaginary parts, respectively, of the complex +C eigenvalues of the selected 2-by-2 diagonal block of A. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Let A1 = ( A(L,L) A(L,L+1) ) +C ( A(L+1,L) A(L+1,L+1) ) +C be the specified 2-by-2 diagonal block of matrix A. +C If the eigenvalues of A1 are complex, then they are computed and +C stored in E1 and E2, where the real part is stored in E1 and the +C positive imaginary part in E2. The 2-by-2 block is reduced if +C necessary to the standard form, such that A(L,L) = A(L+1,L+1), and +C A(L,L+1) and A(L+1,L) have oposite signs. If the eigenvalues are +C real, the 2-by-2 block is reduced to an upper triangular form such +C that ABS(A(L,L)) >= ABS(A(L+1,L+1)). +C In both cases, an orthogonal rotation U1' is constructed such that +C U1'*A1*U1 has the appropriate form. Let UT be an extension of U1 +C to an N-by-N orthogonal matrix, using identity submatrices. Then A +C is replaced by UT'*A*UT and the contents of array U is U * UT. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, +C March 1998. Based on the RASP routine SPLITB. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalues, orthogonal transformation, real Schur form, +C similarity transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, L, LDA, LDU, N + DOUBLE PRECISION E1, E2 +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), U(LDU,*) +C .. Local Scalars .. + INTEGER L1 + DOUBLE PRECISION EW1, EW2, CS, SN +C .. External Subroutines .. + EXTERNAL DLANV2, DROT, XERBLA +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.2 ) THEN + INFO = -1 + ELSE IF( L.LT.1 .OR. L.GE.N ) THEN + INFO = -2 + ELSE IF( LDA.LT.N ) THEN + INFO = -4 + ELSE IF( LDU.LT.N ) THEN + INFO = -6 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB03QY', -INFO ) + RETURN + END IF +C +C Compute the eigenvalues and the elements of the Givens +C transformation. +C + L1 = L + 1 + CALL DLANV2( A(L,L), A(L,L1), A(L1,L), A(L1,L1), E1, E2, + $ EW1, EW2, CS, SN ) + IF( E2.EQ.ZERO ) E2 = EW1 +C +C Apply the transformation to A. +C + IF( L1.LT.N ) + $ CALL DROT( N-L1, A(L,L1+1), LDA, A(L1,L1+1), LDA, CS, SN ) + CALL DROT( L-1, A(1,L), 1, A(1,L1), 1, CS, SN ) +C +C Accumulate the transformation in U. +C + CALL DROT( N, U(1,L), 1, U(1,L1), 1, CS, SN ) +C + RETURN +C *** Last line of MB03QY *** + END Added: trunk/octave-forge/extra/control-oo/src/MB04ND.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/MB04ND.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/MB04ND.f 2009-12-04 04:46:15 UTC (rev 6593) @@ -0,0 +1,257 @@ + SUBROUTINE MB04ND( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, + $ TAU, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To calculate an RQ factorization of the first block row and +C apply the orthogonal transformations (from the right) also to the +C second block row of a structured matrix, as follows +C _ +C [ A R ] [ 0 R ] +C [ ] * Q' = [ _ _ ] +C [ C B ] [ C B ] +C _ +C where R and R are upper triangular. The matrix A can be full or +C upper trapezoidal/triangular. The problem structure is exploited. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Indicates if the matrix A is or not triangular as follows: +C = 'U': Matrix A is upper trapezoidal/triangular; +C = 'F': Matrix A is full. +C +C Input/Output Parameters +C +C N (input) INTEGER _ +C The order of the matrices R and R. N >= 0. +C +C M (input) INTEGER +C The number of rows of the matrices B and C. M >= 0. +C +C P (input) INTEGER +C The number of columns of the matrices A and C. P >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix R. +C On exit, the leading N-by-N upper triangular part of this +C _ +C array contains the upper triangular matrix R. +C The strict lower triangular part of this array is not +C referenced. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,P) +C On entry, if UPLO = 'F', the leading N-by-P part of this +C array must contain the matrix A. For UPLO = 'U', if +C N <= P, the upper triangle of the subarray A(1:N,P-N+1:P) +C must contain the N-by-N upper triangular matrix A, and if +C N >= P, the elements on and above the (N-P)-th subdiagonal +C must contain the N-by-P upper trapezoidal matrix A. +C On exit, if UPLO = 'F', the leading N-by-P part of this +C array contains the trailing components (the vectors v, see +C METHOD) of the elementary reflectors used in the +C factorization. If UPLO = 'U', the upper triangle of the +C subarray A(1:N,P-N+1:P) (if N <= P), or the elements on +C and above the (N-P)-th subdiagonal (if N >= P), contain +C the trailing components (the vectors v, see METHOD) of the +C elementary reflectors used in the factorization. +C The remaining elements are not referenced. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix B. +C On exit, the leading M-by-N part of this array contains +C _ +C the computed matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,P) +C On entry, the leading M-by-P part of this array must +C contain the matrix C. +C On exit, the leading M-by-P part of this array contains +C _ +C the computed matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C TAU (output) DOUBLE PRECISION array, dimension (N) +C The scalar factors of the elementary reflectors used. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (MAX(N-1,M)) +C +C METHOD +C +C The routine uses N Householder transformations exploiting the zero +C pattern of the block matrix. A Householder matrix has the form +C +C ( 1 ) +C H = I - tau *u *u', u = ( v ), +C i i i i i ( i) +C +C where v is a P-vector, if UPLO = 'F', or a min(N-i+1,P)-vector, +C i +C if UPLO = 'U'. The components of v are stored in the i-th row +C i +C of A, and tau is stored in TAU(i), i = N,N-1,...,1. +C i +C In-line code for applying Householder transformations is used +C whenever possible (see MB04NY routine). +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary reflector, RQ factorization, orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, LDC, LDR, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ R(LDR,*), TAU(*) +C .. Local Scalars .. + LOGICAL LUPLO + INTEGER I, IM, IP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARFG, MB04NY +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked. +C + IF( MIN( N, P ).EQ.0 ) + $ RETURN +C + LUPLO = LSAME( UPLO, 'U' ) + IF ( LUPLO ) THEN +C + DO 10 I = N, 1, -1 +C +C Annihilate the I-th row of A and apply the transformations +C to the entire block matrix, exploiting its structure. +C + IM = MIN( N-I+1, P ) + IP = MAX( P-N+I, 1 ) + CALL DLARFG( IM+1, R(I,I), A(I,IP), LDA, TAU(I) ) +C +C Compute +C [ 1 ] +C w := [ R(1:I-1,I) A(1:I-1,IP:P) ] * [ ], +C [ v ] +C +C [ R(1:I-1,I) A(1:I-1,IP:P) ] = +C [ R(1:I-1,I) A(1:I-1,IP:P) ] - tau * w * [ 1 v' ]. +C + IF ( I.GT.0 ) +C + $ CALL MB04NY( I-1, IM, A(I,IP), LDA, TAU(I), R(1,I), LDR, + $ A(1,IP), LDA, DWORK ) +C +C Compute +C [ 1 ] +C w := [ B(:,I) C(:,IP:P) ] * [ ], +C [ v ] +C +C [ B(:,I) C(:,IP:P) ] = [ B(:,I) C(:,IP:P) ] - +C tau * w * [ 1 v' ]. +C + IF ( M.GT.0 ) + $ CALL MB04NY( M, IM, A(I,IP), LDA, TAU(I), B(1,I), LDB, + $ C(1,IP), LDC, DWORK ) + 10 CONTINUE +C + ELSE +C + DO 20 I = N, 2 , -1 +C +C Annihilate the I-th row of A and apply the transformations +C to the first block row, exploiting its structure. +C + CALL DLARFG( P+1, R(I,I), A(I,1), LDA, TAU(I) ) +C +C Compute +C [ 1 ] +C w := [ R(1:I-1,I) A(1:I-1,:) ] * [ ], +C [ v ] +C +C [ R(1:I-1,I) A(1:I-1,:) ] = [ R(1:I-1,I) A(1:I-1,:) ] - +C tau * w * [ 1 v' ]. +C + CALL MB04NY( I-1, P, A(I,1), LDA, TAU(I), R(1,I), LDR, A, + $ LDA, DWORK ) + 20 CONTINUE +C + CALL DLARFG( P+1, R(1,1), A(1,1), LDA, TAU(1) ) + IF ( M.GT.0 ) THEN +C +C Apply the transformations to the second block row. +C + DO 30 I = N, 1, -1 +C +C Compute +C [ 1 ] +C w := [ B(:,I) C ] * [ ], +C [ v ] +C +C [ B(:,I) C ] = [ B(:,I) C ] - tau * w * [ 1 v' ]. +C + CALL MB04NY( M, P, A(I,1), LDA, TAU(I), B(1,I), LDB, C, + $ LDC, DWORK ) + 30 CONTINUE +C + END IF + END IF + RETURN +C *** Last line of MB04ND *** + END Added: trunk/octave-forge/extra/control-oo/src/MB04NY.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/MB04NY.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/MB04NY.f 2009-12-04 04:46:15 UTC (rev 6593) @@ -0,0 +1,437 @@ + SUBROUTINE MB04NY( M, N, V, INCV, TAU, A, LDA, B, LDB, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To apply a real elementary reflector H to a real m-by-(n+1) +C matrix C = [ A B ], from the right, where A has one column. H is +C represented in the form +C ( 1 ) +C H = I - tau * u *u', u = ( ), +C ( v ) +C where tau is a real scalar and v is a real n-vector. +C +C If tau = 0, then H is taken to be the unit matrix. +C +C In-line code is used if H has order < 11. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices A and B. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix B. N >= 0. +C +C V (input) DOUBLE PRECISION array, dimension +C (1+(N-1)*ABS( INCV )) +C The vector v in the representation of H. +C +C INCV (input) INTEGER +C The increment between the elements of v. INCV <> 0. +C +C TAU (input) DOUBLE PRECISION +C The scalar factor of the elementary reflector H. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,1) +C On entry, the leading M-by-1 part of this array must +C contain the matrix A. +C On exit, the leading M-by-1 part of this array contains +C the updated matrix A (the first column of C * H). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix B. +C On exit, the leading M-by-N part of this array contains +C the updated matrix B (the last n columns of C * H). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (M) +C DWORK is not referenced if H has order less than 11. +C +C METHOD +C +C The routine applies the elementary reflector H, taking the special +C structure of C into account. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998. +C Based on LAPACK routines DLARFX and DLATZM. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, elementary reflector, orthogonal +C transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INCV, LDA, LDB, M, N + DOUBLE PRECISION TAU +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), V( * ) +C .. Local Scalars .. + INTEGER IV, J + DOUBLE PRECISION SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9, V1, V2, + $ V3, V4, V5, V6, V7, V8, V9 +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER +C +C .. Executable Statements .. +C + IF( TAU.EQ.ZERO ) + $ RETURN +C +C Form C * H, where H has order n+1. +C + GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, + $ 170, 190 ) N+1 +C +C Code for general N. Compute +C +C w := C*u, C := C - tau * w * u'. +C + CALL DCOPY( M, A, 1, DWORK, 1 ) + CALL DGEMV( 'No transpose', M, N, ONE, B, LDB, V, INCV, ONE, + $ DWORK, 1 ) + CALL DAXPY( M, -TAU, DWORK, 1, A, 1 ) + CALL DGER( M, N, -TAU, DWORK, 1, V, INCV, B, LDB ) + GO TO 210 + 10 CONTINUE +C +C Special code for 1 x 1 Householder +C + T1 = ONE - TAU + DO 20 J = 1, M + A( J, 1 ) = T1*A( J, 1 ) + 20 CONTINUE + GO TO 210 + 30 CONTINUE +C +C Special code for 2 x 2 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + DO 40 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + 40 CONTINUE + GO TO 210 + 50 CONTINUE +C +C Special code for 3 x 3 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + DO 60 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + 60 CONTINUE + GO TO 210 + 70 CONTINUE +C +C Special code for 4 x 4 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + DO 80 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + 80 CONTINUE + GO TO 210 + 90 CONTINUE +C +C Special code for 5 x 5 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + DO 100 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + 100 CONTINUE + GO TO 210 + 110 CONTINUE +C +C Special code for 6 x 6 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + IV = IV + INCV + V5 = V( IV ) + T5 = TAU*V5 + DO 120 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + V5*B( J, 5 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + B( J, 5 ) = B( J, 5 ) - SUM*T5 + 120 CONTINUE + GO TO 210 + 130 CONTINUE +C +C Special code for 7 x 7 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + IV = IV + INCV + V5 = V( IV ) + T5 = TAU*V5 + IV = IV + INCV + V6 = V( IV ) + T6 = TAU*V6 + DO 140 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU +... [truncated message content] |
From: <par...@us...> - 2009-12-04 16:21:19
|
Revision: 6594 http://octave.svn.sourceforge.net/octave/?rev=6594&view=rev Author: paramaniac Date: 2009-12-04 16:21:11 +0000 (Fri, 04 Dec 2009) Log Message: ----------- control-oo: add place (SLICOT SB01BD) Modified Paths: -------------- trunk/octave-forge/extra/control-oo/inst/place.m trunk/octave-forge/extra/control-oo/src/Makefile Added Paths: ----------- trunk/octave-forge/extra/control-oo/src/SB01BD.f trunk/octave-forge/extra/control-oo/src/SB01BX.f trunk/octave-forge/extra/control-oo/src/SB01BY.f trunk/octave-forge/extra/control-oo/src/slsb01bd.cc Modified: trunk/octave-forge/extra/control-oo/inst/place.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/place.m 2009-12-04 04:46:15 UTC (rev 6593) +++ trunk/octave-forge/extra/control-oo/inst/place.m 2009-12-04 16:21:11 UTC (rev 6594) @@ -1,136 +1,86 @@ -## Copyright (C) 1997, 2000, 2002, 2003, 2004, 2005, 2007 -## Jose Daniel Munoz Frias +## Copyright (C) 2009 Lukas F. Reichlin ## +## This file is part of LTI Syncope. ## -## 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. +## LTI Syncope 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. +## LTI Syncope 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; see the file COPYING. If not, see -## <http://www.gnu.org/licenses/>. +## along with this program. If not, see <http://www.gnu.org/licenses/>. ## -*- texinfo -*- -## @deftypefn {Function File} {@var{K} =} place (@var{sys}, @var{p}) -## @deftypefnx {Function File} {@var{K} =} place (@var{a}, @var{b}, @var{p}) -## Computes the matrix @var{K} such that if the state -## is feedback with gain @var{K}, then the eigenvalues of the closed loop -## system (i.e. @math{A-BK}) are those specified in the vector @var{p}. -## -## Version: Beta (May-1997): If you have any comments, please let me know. -## (see the file place.m for my address) +## @deftypefn {Function File} {@var{f} =} place (@var{sys}, @var{p}) +## @deftypefnx {Function File} {@var{f} =} place (@var{a}, @var{b}, @var{p}) +## Pole assignment for a given matrix pair (A,B) such that eig (A-B*F) = P. +## Uses SLICOT SB01BD by courtesy of NICONET e.V. +## Special thanks to Peter Benner from TU Chemnitz for his advice. ## @end deftypefn -## Author: Jose Daniel Munoz Frias - -## Universidad Pontificia Comillas -## ICAIdea -## Alberto Aguilera, 23 -## 28015 Madrid, Spain -## -## E-Mail: da...@de... -## -## Phone: 34-1-5422800 Fax: 34-1-5596569 -## -## Algorithm taken from "The Control Handbook", IEEE press pp. 209-212 -## -## code adaped by A.S.Hodel (a.s...@en...) for use in controls -## toolbox - -## Adapted-By: Lukas Reichlin <luk...@gm...> -## Date: October 2009 +## Author: Lukas Reichlin <luk...@gm...> +## Created: December 2009 ## Version: 0.1 -## TODO: Support MIMO systems, use Fortran algorithm from Slicot +function f = place (a, b, p) -function K = place (argin1, argin2, argin3) + ## TODO: add possibility to specify alpha as a fourth parameter - if (nargin == 3) - A = argin1; - B = argin2; - P = argin3; - elseif (nargin == 2) - [A, B] = ssdata (argin1); - P = argin2; + if (nargin == 2) # place (sys, p) + p = b; + [a, b, c, d, tsam] = ssdata (a); + elseif (nargin == 3) # place (a, b, p) + if (! isnumeric (a) || ! isnumeric (b) || ! issquare (a) || rows (a) != rows (b)) + error ("place: matrices a and b not conformal"); + endif + tsam = 0; # assume continuous system else print_usage (); endif - ## check arguments - values of C and D matrices don't matter - [m, nx, p] = __ssmatdim__ (A, B, zeros (1, columns (A)), zeros (1, columns (B))); - - if (m != 1) - error ("place: system has %d inputs; need only 1", m); + if (! isnumeric (p) || ! isvector (p) || isempty (p)) + error ("place: p must be a vector"); endif - - if (! isctrb (A, B)) - error ("place: system is not controllable"); - elseif (! isvector (P)) - error ("place: P must be a vector") + + p = sort (p(:)); # complex conjugate pairs must appear together + wr = real (p); + wi = imag (p); + + n = rows (a); # number of states + np = length (p); # number of given eigenvalues + + if (np > n) + error ("place: at most %d eigenvalues can be assigned for the given matrix a (%dx%d)", + n, n, n); + endif + + if (tsam > 0) + alpha = 0; else - P = P(:); # make P a column vector + alpha = - norm (a, inf); endif - sp = length (P); - - if (nx == 0) - error ("place: A matrix is empty (0x0)"); - elseif (nx != length (P)) - error ("place: A=(%dx%d), P has %d entries", nx, nx, length (P)) + [f, iwarn] = slsb01bd (a, b, wr, wi, tsam, alpha); + f = -f; # A + B*F --> A - B*F + + if (iwarn) + warning ("place: %d violations of the numerical stability condition NORM(F) <= 100*NORM(A)/NORM(B)", + iwarn); endif - ## arguments appear to be compatible; let's give it a try! - ## The second step is the calculation of the characteristic polynomial ofA - PC = poly (A); - - ## Third step: Calculate the transformation matrix T that transforms the state - ## equation in the controllable canonical form. - - ## first we must calculate the controllability matrix M: - M = ctrb (A, B); - - ## second, construct the matrix W - PCO = PC(nx:-1:1); - PC1 = PCO; # Matrix to shift and create W row by row - - for n = 1:nx - W(n,:) = PC1; - PC1 = [PCO(n+1:nx), zeros(1,n)]; - endfor - - T = M*W; - - ## finaly the matrix K is calculated - PD = poly (P); # The desired characteristic polynomial - PD = PD(nx+1:-1:2); - PC = PC(nx+1:-1:2); - - K = (PD-PC)/T; - - ## Check if the eigenvalues of (A-BK) are the same specified in P - Pcalc = eig (A-B*K); - - Pcalc = sort (Pcalc); - P = sort (P); - - if (max ((abs(Pcalc)-abs(P))./abs(P) ) > 0.1) - warning ("place: pole placed at more than 10% relative error from specified"); - endif - endfunction %!shared A, B, C, P, Kexpected -%! A = [0 1; 3 2]; +%! A = [0, 1; 3, 2]; %! B = [0; 1]; -%! C = [2 1]; # C is useful to use ss; it doesn't matter what the value of C is -%! P = [-1 -0.5]; -%! Kexpected = [3.5 3.5]; +%! C = [2, 1]; # C is needed for ss; it doesn't matter what the value of C is +%! P = [-1, -0.5]; +%! Kexpected = [3.5, 3.5]; %!assert (place (ss (A, B, C), P), Kexpected, 2*eps); %!assert (place (A, B, P), Kexpected, 2*eps); \ No newline at end of file Modified: trunk/octave-forge/extra/control-oo/src/Makefile =================================================================== --- trunk/octave-forge/extra/control-oo/src/Makefile 2009-12-04 04:46:15 UTC (rev 6593) +++ trunk/octave-forge/extra/control-oo/src/Makefile 2009-12-04 16:21:11 UTC (rev 6594) @@ -1,4 +1,4 @@ -all: slab08nd.oct slab13dd.oct slsb10hd.oct slsb10ed.oct slab13bd.oct +all: slab08nd.oct slab13dd.oct slsb10hd.oct slsb10ed.oct slab13bd.oct slsb01bd.oct # transmission zeros of state-space models slab08nd.oct: slab08nd.cc @@ -42,5 +42,11 @@ SB03OR.f MB04OX.f MB03QD.f SB03OY.f MA02AD.f \ MB03QY.f SB04PX.f MB04NY.f MB04OY.f SB03OV.f +# Pole assignment +slsb01bd.oct: slsb01bd.cc + mkoctfile slsb01bd.cc \ + SB01BD.f MB03QD.f MB03QY.f SB01BX.f SB01BY.f \ + select.f + clean: rm *.o core octave-core *.oct *~ Added: trunk/octave-forge/extra/control-oo/src/SB01BD.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/SB01BD.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/SB01BD.f 2009-12-04 16:21:11 UTC (rev 6594) @@ -0,0 +1,776 @@ + SUBROUTINE SB01BD( DICO, N, M, NP, ALPHA, A, LDA, B, LDB, WR, WI, + $ NFP, NAP, NUP, F, LDF, Z, LDZ, TOL, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To determine the state feedback matrix F for a given system (A,B) +C such that the closed-loop state matrix A+B*F has specified +C eigenvalues. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the state vector, i.e. the order of the +C matrix A, and also the number of rows of the matrix B and +C the number of columns of the matrix F. N >= 0. +C +C M (input) INTEGER +C The dimension of input vector, i.e. the number of columns +C of the matrix B and the number of rows of the matrix F. +C M >= 0. +C +C NP (input) INTEGER +C The number of given eigenvalues. At most N eigenvalues +C can be assigned. 0 <= NP. +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the maximum admissible value, either for real +C parts, if DICO = 'C', or for moduli, if DICO = 'D', +C of the eigenvalues of A which will not be modified by +C the eigenvalue assignment algorithm. +C ALPHA >= 0 if DICO = 'D'. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading N-by-N part of this array contains +C the matrix Z'*(A+B*F)*Z in a real Schur form. +C The leading NFP-by-NFP diagonal block of A corresponds +C to the fixed (unmodified) eigenvalues having real parts +C less than ALPHA, if DICO = 'C', or moduli less than ALPHA, +C if DICO = 'D'. The trailing NUP-by-NUP diagonal block of A +C corresponds to the uncontrollable eigenvalues detected by +C the eigenvalue assignment algorithm. The elements under +C the first subdiagonal are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C WR,WI (input/output) DOUBLE PRECISION array, dimension (NP) +C On entry, these arrays must contain the real and imaginary +C parts, respectively, of the desired eigenvalues of the +C closed-loop system state-matrix A+B*F. The eigenvalues +C can be unordered, except that complex conjugate pairs +C must appear consecutively in these arrays. +C On exit, if INFO = 0, the leading NAP elements of these +C arrays contain the real and imaginary parts, respectively, +C of the assigned eigenvalues. The trailing NP-NAP elements +C contain the unassigned eigenvalues. +C +C NFP (output) INTEGER +C The number of eigenvalues of A having real parts less than +C ALPHA, if DICO = 'C', or moduli less than ALPHA, if +C DICO = 'D'. These eigenvalues are not modified by the +C eigenvalue assignment algorithm. +C +C NAP (output) INTEGER +C The number of assigned eigenvalues. If INFO = 0 on exit, +C then NAP = N-NFP-NUP. +C +C NUP (output) INTEGER +C The number of uncontrollable eigenvalues detected by the +C eigenvalue assignment algorithm (see METHOD). +C +C F (output) DOUBLE PRECISION array, dimension (LDF,N) +C The leading M-by-N part of this array contains the state +C feedback F, which assigns NAP closed-loop eigenvalues and +C keeps unaltered N-NAP open-loop eigenvalues. +C +C LDF INTEGER +C The leading dimension of array F. LDF >= MAX(1,M). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C The leading N-by-N part of this array contains the +C orthogonal matrix Z which reduces the closed-loop +C system state matrix A + B*F to upper real Schur form. +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The absolute tolerance level below which the elements of A +C or B are considered zero (used for controllability tests). +C If the user sets TOL <= 0, then the default tolerance +C TOL = N * EPS * max(NORM(A),NORM(B)) is used, where EPS is +C the machine precision (see LAPACK Library routine DLAMCH) +C and NORM(A) denotes the 1-norm of A. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. +C LDWORK >= MAX( 1,5*M,5*N,2*N+4*M ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = K: K violations of the numerical stability condition +C NORM(F) <= 100*NORM(A)/NORM(B) occured during the +C assignment of eigenvalues. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to a real Schur form failed; +C = 2: a failure was detected during the ordering of the +C real Schur form of A, or in the iterative process +C for reordering the eigenvalues of Z'*(A + B*F)*Z +C along the diagonal. +C = 3: the number of eigenvalues to be assigned is less +C than the number of possibly assignable eigenvalues; +C NAP eigenvalues have been properly assigned, +C but some assignable eigenvalues remain unmodified. +C = 4: an attempt is made to place a complex conjugate +C pair on the location of a real eigenvalue. This +C situation can only appear when N-NFP is odd, +C NP > N-NFP-NUP is even, and for the last real +C eigenvalue to be modified there exists no available +C real eigenvalue to be assigned. However, NAP +C eigenvalues have been already properly assigned. +C +C METHOD +C +C SB01BD is based on the factorization algorithm of [1]. +C Given the matrices A and B of dimensions N-by-N and N-by-M, +C respectively, this subroutine constructs an M-by-N matrix F such +C that A + BF has eigenvalues as follows. +C Let NFP eigenvalues of A have real parts less than ALPHA, if +C DICO = 'C', or moduli less then ALPHA, if DICO = 'D'. Then: +C 1) If the pair (A,B) is controllable, then A + B*F has +C NAP = MIN(NP,N-NFP) eigenvalues assigned from those specified +C by WR + j*WI and N-NAP unmodified eigenvalues; +C 2) If the pair (A,B) is uncontrollable, then the number of +C assigned eigenvalues NAP satifies generally the condition +C NAP <= MIN(NP,N-NFP). +C +C At the beginning of the algorithm, F = 0 and the matrix A is +C reduced to an ordered real Schur form by separating its spectrum +C in two parts. The leading NFP-by-NFP part of the Schur form of +C A corresponds to the eigenvalues which will not be modified. +C These eigenvalues have real parts less than ALPHA, if +C DICO = 'C', or moduli less than ALPHA, if DICO = 'D'. +C The performed orthogonal transformations are accumulated in Z. +C After this preliminary reduction, the algorithm proceeds +C recursively. +C +C Let F be the feedback matrix at the beginning of a typical step i. +C At each step of the algorithm one real eigenvalue or two complex +C conjugate eigenvalues are placed by a feedback Fi of rank 1 or +C rank 2, respectively. Since the feedback Fi affects only the +C last 1 or 2 columns of Z'*(A+B*F)*Z, the matrix Z'*(A+B*F+B*Fi)*Z +C therefore remains in real Schur form. The assigned eigenvalue(s) +C is (are) then moved to another diagonal position of the real +C Schur form using reordering techniques and a new block is +C transfered in the last diagonal position. The feedback matrix F +C is updated as F <-- F + Fi. The eigenvalue(s) to be assigned at +C each step is (are) chosen such that the norm of each Fi is +C minimized. +C +C If uncontrollable eigenvalues are encountered in the last diagonal +C position of the real Schur matrix Z'*(A+B*F)*Z, the algorithm +C deflates them at the bottom of the real Schur form and redefines +C accordingly the position of the "last" block. +C +C Note: Not all uncontrollable eigenvalues of the pair (A,B) are +C necessarily detected by the eigenvalue assignment algorithm. +C Undetected uncontrollable eigenvalues may exist if NFP > 0 and/or +C NP < N-NFP. +C +C REFERENCES +C +C [1] Varga A. +C A Schur method for pole assignment. +C IEEE Trans. Autom. Control, Vol. AC-26, pp. 517-519, 1981. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires no more than 14N floating point +C operations. Although no proof of numerical stability is known, +C the algorithm has always been observed to yield reliable +C numerical results. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C February 1999. Based on the RASP routine SB01BD. +C +C REVISIONS +C +C March 30, 1999, V. Sima, Research Institute for Informatics, +C Bucharest. +C April 4, 1999. A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen. +C May 18, 2003. A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen. +C Feb. 15, 2004, V. Sima, Research Institute for Informatics, +C Bucharest. +C May 12, 2005. A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen. +C +C KEYWORDS +C +C Eigenvalues, eigenvalue assignment, feedback control, +C pole placement, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION HUNDR, ONE, TWO, ZERO + PARAMETER ( HUNDR = 1.0D2, ONE = 1.0D0, TWO = 2.0D0, + $ ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO + INTEGER INFO, IWARN, LDA, LDB, LDF, LDWORK, LDZ, M, N, + $ NAP, NFP, NP, NUP + DOUBLE PRECISION ALPHA, TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*), + $ WI(*), WR(*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL CEIG, DISCR, SIMPLB + INTEGER I, IB, IB1, IERR, IPC, J, K, KFI, KG, KW, KWI, + $ KWR, NCUR, NCUR1, NL, NLOW, NMOVES, NPC, NPR, + $ NSUP, WRKOPT + DOUBLE PRECISION ANORM, BNORM, C, P, RMAX, S, X, Y, TOLER, TOLERB +C .. Local Arrays .. + LOGICAL BWORK(1) + DOUBLE PRECISION A2(2,2) +C .. External Functions .. + LOGICAL LSAME, SELECT + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME, SELECT +C .. External Subroutines .. + EXTERNAL DGEES, DGEMM, DLAEXC, DLASET, DROT, DSWAP, + $ MB03QD, MB03QY, SB01BX, SB01BY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C + DISCR = LSAME( DICO, 'D' ) + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( NP.LT.0 ) THEN + INFO = -4 + ELSE IF( DISCR .AND. ( ALPHA.LT.ZERO ) ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -16 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDWORK.LT.MAX( 1, 5*M, 5*N, 2*N + 4*M ) ) THEN + INFO = -21 + END IF + IF( INFO.NE.0 )THEN +C +C Error return. +C + CALL XERBLA( 'SB01BD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + NFP = 0 + NAP = 0 + NUP = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Compute the norms of A and B, and set default tolerances +C if necessary. +C + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) + BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) + IF( TOL.LE.ZERO ) THEN + X = DLAMCH( 'Epsilon' ) + TOLER = DBLE( N ) * MAX( ANORM, BNORM ) * X + TOLERB = DBLE( N ) * BNORM * X + ELSE + TOLER = TOL + TOLERB = TOL + END IF +C +C Allocate working storage. +C + KWR = 1 + KWI = KWR + N + KW = KWI + N +C +C Reduce A to real Schur form using an orthogonal similarity +C transformation A <- Z'*A*Z and accumulate the transformation in Z. +C +C Workspace: need 5*N; +C prefer larger. +C + CALL DGEES( 'Vectors', 'No ordering', SELECT, N, A, LDA, NCUR, + $ DWORK(KWR), DWORK(KWI), Z, LDZ, DWORK(KW), + $ LDWORK-KW+1, BWORK, INFO ) + WRKOPT = KW - 1 + INT( DWORK( KW ) ) + IF( INFO.NE.0 ) THEN + INFO = 1 + RETURN + END IF +C +C Reduce A to an ordered real Schur form using an orthogonal +C similarity transformation A <- Z'*A*Z and accumulate the +C transformations in Z. The separation of the spectrum of A is +C performed such that the leading NFP-by-NFP submatrix of A +C corresponds to the "good" eigenvalues which will not be +C modified. The bottom (N-NFP)-by-(N-NFP) diagonal block of A +C corresponds to the "bad" eigenvalues to be modified. +C +C Workspace needed: N. +C + CALL MB03QD( DICO, 'Stable', 'Update', N, 1, N, ALPHA, + $ A, LDA, Z, LDZ, NFP, DWORK, INFO ) + IF( INFO.NE.0 ) + $ RETURN +C +C Set F = 0. +C + CALL DLASET( 'Full', M, N, ZERO, ZERO, F, LDF ) +C +C Return if B is negligible (uncontrollable system). +C + IF( BNORM.LE.TOLERB ) THEN + NAP = 0 + NUP = N + DWORK(1) = WRKOPT + RETURN + END IF +C +C Compute the bound for the numerical stability condition. +C + RMAX = HUNDR * ANORM / BNORM +C +C Perform eigenvalue assignment if there exist "bad" eigenvalues. +C + NAP = 0 + NUP = 0 + IF( NFP .LT. N ) THEN + KG = 1 + KFI = KG + 2*M + KW = KFI + 2*M +C +C Set the limits for the bottom diagonal block. +C + NLOW = NFP + 1 + NSUP = N +C +C Separate and count real and complex eigenvalues to be assigned. +C + NPR = 0 + DO 10 I = 1, NP + IF( WI(I) .EQ. ZERO ) THEN + NPR = NPR + 1 + K = I - NPR + IF( K .GT. 0 ) THEN + S = WR(I) + DO 5 J = NPR + K - 1, NPR, -1 + WR(J+1) = WR(J) + WI(J+1) = WI(J) + 5 CONTINUE + WR(NPR) = S + WI(NPR) = ZERO + END IF + END IF + 10 CONTINUE + NPC = NP - NPR +C +C The first NPR elements of WR and WI contain the real +C eigenvalues, the last NPC elements contain the complex +C eigenvalues. Set the pointer to complex eigenvalues. +C + IPC = NPR + 1 +C +C Main loop for assigning one or two eigenvalues. +C +C Terminate if all eigenvalues were assigned, or if there +C are no more eigenvalues to be assigned, or if a non-fatal +C error condition was set. +C +C WHILE (NLOW <= NSUP and INFO = 0) DO +C + 20 IF( NLOW.LE.NSUP .AND. INFO.EQ.0 ) THEN +C +C Determine the dimension of the last block. +C + IB = 1 + IF( NLOW.LT.NSUP ) THEN + IF( A(NSUP,NSUP-1).NE.ZERO ) IB = 2 + END IF +C +C Compute G, the current last IB rows of Z'*B. +C + NL = NSUP - IB + 1 + CALL DGEMM( 'Transpose', 'NoTranspose', IB, M, N, ONE, + $ Z(1,NL), LDZ, B, LDB, ZERO, DWORK(KG), IB ) +C +C Check the controllability for a simple block. +C + IF( DLANGE( '1', IB, M, DWORK(KG), IB, DWORK(KW) ) + $ .LE. TOLERB ) THEN +C +C Deflate the uncontrollable block and resume the +C main loop. +C + NSUP = NSUP - IB + NUP = NUP + IB + GO TO 20 + END IF +C +C Test for termination with INFO = 3. +C + IF( NAP.EQ.NP) THEN + INFO = 3 +C +C Test for compatibility. Terminate if an attempt occurs +C to place a complex conjugate pair on a 1x1 block. +C + ELSE IF( IB.EQ.1 .AND. NPR.EQ.0 .AND. NLOW.EQ.NSUP ) THEN + INFO = 4 + ELSE +C +C Set the simple block flag. +C + SIMPLB = .TRUE. +C +C Form a 2-by-2 block if necessary from two 1-by-1 blocks. +C Consider special case IB = 1, NPR = 1 and +C NPR+NPC > NSUP-NLOW+1 to avoid incompatibility. +C + IF( ( IB.EQ.1 .AND. NPR.EQ.0 ) .OR. + $ ( IB.EQ.1 .AND. NPR.EQ.1 .AND. NSUP.GT.NLOW .AND. + $ NPR+NPC.GT.NSUP-NLOW+1 ) ) THEN + IF( NSUP.GT.2 ) THEN + IF( A(NSUP-1,NSUP-2) .NE. ZERO ) THEN +C +C Interchange with the adjacent 2x2 block. +C +C Workspace needed: N. +C + CALL DLAEXC( .TRUE., N, A, LDA, Z, LDZ, NSUP-2, + $ 2, 1, DWORK(KW), INFO ) + IF( INFO .NE. 0 ) THEN + INFO = 2 + RETURN + END IF + ELSE +C +C Form a non-simple block by extending the last +C block with a 1x1 block. +C + SIMPLB = .FALSE. + END IF + ELSE + SIMPLB = .FALSE. + END IF + IB = 2 + END IF + NL = NSUP - IB + 1 +C +C Compute G, the current last IB rows of Z'*B. +C + CALL DGEMM( 'Transpose', 'NoTranspose', IB, M, N, ONE, + $ Z(1,NL), LDZ, B, LDB, ZERO, DWORK(KG), IB ) +C +C Check the controllability for the current block. +C + IF( DLANGE( '1', IB, M, DWORK(KG), IB, DWORK(KW) ) + $ .LE. TOLERB ) THEN +C +C Deflate the uncontrollable block and resume the +C main loop. +C + NSUP = NSUP - IB + NUP = NUP + IB + GO TO 20 + END IF +C + IF( NAP+IB .GT. NP ) THEN +C +C No sufficient eigenvalues to be assigned. +C + INFO = 3 + ELSE + IF( IB .EQ. 1 ) THEN +C +C A 1-by-1 block. +C +C Assign the real eigenvalue nearest to A(NSUP,NSUP). +C + X = A(NSUP,NSUP) + CALL SB01BX( .TRUE., NPR, X, X, WR, X, S, P ) + NPR = NPR - 1 + CEIG = .FALSE. + ELSE +C +C A 2-by-2 block. +C + IF( SIMPLB ) THEN +C +C Simple 2-by-2 block with complex eigenvalues. +C Compute the eigenvalues of the last block. +C + CALL MB03QY( N, NL, A, LDA, Z, LDZ, X, Y, INFO ) + IF( NPC .GT. 1 ) THEN + CALL SB01BX( .FALSE., NPC, X, Y, + $ WR(IPC), WI(IPC), S, P ) + NPC = NPC - 2 + CEIG = .TRUE. + ELSE +C +C Choose the nearest two real eigenvalues. +C + CALL SB01BX( .TRUE., NPR, X, X, WR, X, S, P ) + CALL SB01BX( .TRUE., NPR-1, X, X, WR, X, + $ Y, P ) + P = S * Y + S = S + Y + NPR = NPR - 2 + CEIG = .FALSE. + END IF + ELSE +C +C Non-simple 2x2 block with real eigenvalues. +C Choose the nearest pair of complex eigenvalues. +C + X = ( A(NL,NL) + A(NSUP,NSUP) )/TWO + CALL SB01BX( .FALSE., NPC, X, ZERO, WR(IPC), + $ WI(IPC), S, P ) + NPC = NPC - 2 + END IF + END IF +C +C Form the IBxIB matrix A2 from the current diagonal +C block. +C + A2(1,1) = A(NL,NL) + IF( IB .GT. 1 ) THEN + A2(1,2) = A(NL,NSUP) + A2(2,1) = A(NSUP,NL) + A2(2,2) = A(NSUP,NSUP) + END IF +C +C Determine the M-by-IB feedback matrix FI which +C assigns the chosen IB eigenvalues for the pair (A2,G). +C +C Workspace needed: 5*M. +C + CALL SB01BY( IB, M, S, P, A2, DWORK(KG), DWORK(KFI), + $ TOLER, DWORK(KW), IERR ) + IF( IERR .NE. 0 ) THEN + IF( IB.EQ.1 .OR. SIMPLB ) THEN +C +C The simple 1x1 block is uncontrollable. +C + NSUP = NSUP - IB + IF( CEIG ) THEN + NPC = NPC + IB + ELSE + NPR = NPR + IB + END IF + NUP = NUP + IB + ELSE +C +C The non-simple 2x2 block is uncontrollable. +C Eliminate its uncontrollable part by using +C the information in elements FI(1,1) and F(1,2). +C + C = DWORK(KFI) + S = DWORK(KFI+IB) +C +C Apply the transformation to A and accumulate it +C in Z. +C + CALL DROT( N-NL+1, A(NL,NL), LDA, + $ A(NSUP,NL), LDA, C, S ) + CALL DROT( N, A(1,NL), 1, A(1,NSUP), 1, C, S ) + CALL DROT( N, Z(1,NL), 1, Z(1,NSUP), 1, C, S ) +C +C Annihilate the subdiagonal element of the last +C block, redefine the upper limit for the bottom +C block and resume the main loop. +C + A(NSUP,NL) = ZERO + NSUP = NL + NUP = NUP + 1 + NPC = NPC + 2 + END IF + ELSE +C +C Successful assignment of IB eigenvalues. +C +C Update the feedback matrix F <-- F + [0 FI]*Z'. +C + CALL DGEMM( 'NoTranspose', 'Transpose', M, N, + $ IB, ONE, DWORK(KFI), M, Z(1,NL), + $ LDZ, ONE, F, LDF ) +C +C Check for possible numerical instability. +C + IF( DLANGE( '1', M, IB, DWORK(KFI), M, DWORK(KW) ) + $ .GT. RMAX ) IWARN = IWARN + 1 +C +C Update the state matrix A <-- A + Z'*B*[0 FI]. +C Workspace needed: 2*N+4*M. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, IB, + $ M, ONE, B, LDB, DWORK(KFI), M, ZERO, + $ DWORK(KW), N ) + CALL DGEMM( 'Transpose', 'NoTranspose', NSUP, + $ IB, N, ONE, Z, LDZ, DWORK(KW), N, + $ ONE, A(1,NL), LDA ) +C +C Try to split the 2x2 block. +C + IF( IB .EQ. 2 ) + $ CALL MB03QY( N, NL, A, LDA, Z, LDZ, X, Y, + $ INFO ) + NAP = NAP + IB + IF( NLOW+IB.LE.NSUP ) THEN +C +C Move the last block(s) to the leading +C position(s) of the bottom block. +C + NCUR1 = NSUP - IB + NMOVES = 1 + IF( IB.EQ.2 .AND. A(NSUP,NSUP-1).EQ.ZERO ) THEN + IB = 1 + NMOVES = 2 + END IF +C +C WHILE (NMOVES > 0) DO + 30 IF( NMOVES .GT. 0 ) THEN + NCUR = NCUR1 +C +C WHILE (NCUR >= NLOW) DO + 40 IF( NCUR .GE. NLOW ) THEN +C +C Loop for the last block positioning. +C + IB1 = 1 + IF( NCUR.GT.NLOW ) THEN + IF( A(NCUR,NCUR-1).NE.ZERO ) IB1 = 2 + END IF + CALL DLAEXC( .TRUE., N, A, LDA, Z, LDZ, + $ NCUR-IB1+1, IB1, IB, + $ DWORK(KW), INFO ) + IF( INFO .NE. 0 ) THEN + INFO = 2 + RETURN + END IF + NCUR = NCUR - IB1 + GO TO 40 + END IF +C +C END WHILE 40 +C + NMOVES = NMOVES - 1 + NCUR1 = NCUR1 + 1 + NLOW = NLOW + IB + GO TO 30 + END IF +C +C END WHILE 30 +C + ELSE + NLOW = NLOW + IB + END IF + END IF + END IF + END IF + IF( INFO.EQ.0 ) GO TO 20 +C +C END WHILE 20 +C + END IF +C + WRKOPT = MAX( WRKOPT, 5*M, 2*N + 4*M ) + END IF +C +C Annihilate the elements below the first subdiagonal of A. +C + IF( N .GT. 2) + $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) + IF( NAP .GT. 0 ) THEN +C +C Move the assigned eigenvalues in the first NAP positions of +C WR and WI. +C + K = IPC - NPR - 1 + IF( K .GT. 0 ) CALL DSWAP( K, WR(NPR+1), 1, WR, 1 ) + J = NAP - K + IF( J .GT. 0 ) THEN + CALL DSWAP( J, WR(IPC+NPC), 1, WR(K+1), 1 ) + CALL DSWAP( J, WI(IPC+NPC), 1, WI(K+1), 1 ) + END IF + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB01BD *** + END Added: trunk/octave-forge/extra/control-oo/src/SB01BX.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/SB01BX.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/SB01BX.f 2009-12-04 16:21:11 UTC (rev 6594) @@ -0,0 +1,150 @@ + SUBROUTINE SB01BX( REIG, N, XR, XI, WR, WI, S, P ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To choose a real eigenvalue or a pair of complex conjugate +C eigenvalues at "minimal" distance to a given real or complex +C value. +C +C ARGUMENTS +C +C Mode Parameters +C +C REIG LOGICAL +C Specifies the type of eigenvalues as follows: +C = .TRUE., a real eigenvalue is to be selected; +C = .FALSE., a pair of complex eigenvalues is to be +C selected. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of eigenvalues contained in the arrays WR +C and WI. N >= 1. +C +C XR,XI (input) DOUBLE PRECISION +C If REIG = .TRUE., XR must contain the real value and XI +C is assumed zero and therefore not referenced. +C If REIG = .FALSE., XR must contain the real part and XI +C the imaginary part, respectively, of the complex value. +C +C WR,WI (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, if REIG = .TRUE., WR must contain the real +C eigenvalues from which an eigenvalue at minimal distance +C to XR is to be selected. In this case, WI is considered +C zero and therefore not referenced. +C On entry, if REIG = .FALSE., WR and WI must contain the +C real and imaginary parts, respectively, of the eigenvalues +C from which a pair of complex conjugate eigenvalues at +C minimal "distance" to XR + jXI is to be selected. +C The eigenvalues of each pair of complex conjugate +C eigenvalues must appear consecutively. +C On exit, the elements of these arrays are reordered such +C that the selected eigenvalue(s) is (are) found in the +C last element(s) of these arrays. +C +C S,P (output) DOUBLE PRECISION +C If REIG = .TRUE., S (and also P) contains the value of +C the selected real eigenvalue. +C If REIG = .FALSE., S and P contain the sum and product, +C respectively, of the selected complex conjugate pair of +C eigenvalues. +C +C FURTHER COMMENTS +C +C For efficiency reasons, |x| + |y| is used for a complex number +C x + jy, instead of its modulus. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C February 1999. Based on the RASP routine PMDIST. +C +C REVISIONS +C +C March 30, 1999, V. Sima, Research Institute for Informatics, +C Bucharest. +C Feb. 15, 2004, V. Sima, Research Institute for Informatics, +C Bucharest. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + LOGICAL REIG + INTEGER N + DOUBLE PRECISION P, S, XI ,XR +C .. Array Arguments .. + DOUBLE PRECISION WI(*), WR(*) +C .. Local Scalars .. + INTEGER I, J, K + DOUBLE PRECISION X, Y +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + J = 1 + IF( REIG ) THEN + Y = ABS( WR(1)-XR ) + DO 10 I = 2, N + X = ABS( WR(I)-XR ) + IF( X .LT. Y ) THEN + Y = X + J = I + END IF + 10 CONTINUE + S = WR(J) + K = N - J + IF( K .GT. 0 ) THEN + DO 20 I = J, J + K - 1 + WR(I) = WR(I+1) + 20 CONTINUE + WR(N) = S + END IF + P = S + ELSE + Y = ABS( WR(1)-XR ) + ABS( WI(1)-XI ) + DO 30 I = 3, N, 2 + X = ABS( WR(I)-XR ) + ABS( WI(I)-XI ) + IF( X .LT. Y ) THEN + Y = X + J = I + END IF + 30 CONTINUE + X = WR(J) + Y = WI(J) + K = N - J - 1 + IF( K .GT. 0 ) THEN + DO 40 I = J, J + K - 1 + WR(I) = WR(I+2) + WI(I) = WI(I+2) + 40 CONTINUE + WR(N-1) = X + WI(N-1) = Y + WR(N) = X + WI(N) = -Y + END IF + S = X + X + P = X * X + Y * Y + END IF +C + RETURN +C *** End of SB01BX *** + END Added: trunk/octave-forge/extra/control-oo/src/SB01BY.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/SB01BY.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/SB01BY.f 2009-12-04 16:21:11 UTC (rev 6594) @@ -0,0 +1,332 @@ + SUBROUTINE SB01BY( N, M, S, P, A, B, F, TOL, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To solve an N-by-N pole placement problem for the simple cases +C N = 1 or N = 2: given the N-by-N matrix A and N-by-M matrix B, +C construct an M-by-N matrix F such that A + B*F has prescribed +C eigenvalues. These eigenvalues are specified by their sum S and +C product P (if N = 2). The resulting F has minimum Frobenius norm. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A and also the number of rows of +C the matrix B and the number of columns of the matrix F. +C N is either 1, if a single real eigenvalue is prescribed +C or 2, if a complex conjugate pair or a set of two real +C eigenvalues are prescribed. +C +C M (input) INTEGER +C The number of columns of the matrix B and also the number +C of rows of the matrix F. M >= 1. +C +C S (input) DOUBLE PRECISION +C The sum of the prescribed eigenvalues if N = 2 or the +C value of prescribed eigenvalue if N = 1. +C +C P (input) DOUBLE PRECISION +C The product of the prescribed eigenvalues if N = 2. +C Not referenced if N = 1. +C +C A (input/output) DOUBLE PRECISION array, dimension (N,N) +C On entry, this array must contain the N-by-N state +C dynamics matrix whose eigenvalues have to be moved to +C prescribed locations. +C On exit, this array contains no useful information. +C +C B (input/output) DOUBLE PRECISION array, dimension (N,M) +C On entry, this array must contain the N-by-M input/state +C matrix B. +C On exit, this array contains no useful information. +C +C F (output) DOUBLE PRECISION array, dimension (M,N) +C The state feedback matrix F which assigns one pole or two +C poles of the closed-loop matrix A + B*F. +C If N = 2 and the pair (A,B) is not controllable +C (INFO = 1), then F(1,1) and F(1,2) contain the elements of +C an orthogonal rotation which can be used to remove the +C uncontrollable part of the pair (A,B). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The absolute tolerance level below which the elements of A +C and B are considered zero (used for controllability test). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if uncontrollability of the pair (A,B) is detected. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine SB01BY. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C May 2003, A. Varga, German Aerospace Center. +C +C KEYWORDS +C +C Eigenvalue, eigenvalue assignment, feedback control, pole +C placement, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION FOUR, ONE, THREE, TWO, ZERO + PARAMETER ( FOUR = 4.0D0, ONE = 1.0D0, THREE = 3.0D0, + $ TWO = 2.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, M, N + DOUBLE PRECISION P, S, TOL +C .. Array Arguments .. + DOUBLE PRECISION A(N,*), B(N,*), DWORK(*), F(M,*) +C .. Local Scalars .. + INTEGER IR, J + DOUBLE PRECISION ABSR, B1, B2, B21, C, C0, C1, C11, C12, C21, + $ C22, C3, C4, CS, CU, CV, DC0, DC2, DC3, DIFFR, + $ R, RN, S12, S21, SIG, SN, SU, SV, TAU1, TAU2, + $ WI, WI1, WR, WR1, X, Y, Z +C .. External Functions .. + DOUBLE PRECISION DLAMC3, DLAMCH + EXTERNAL DLAMC3, DLAMCH +C .. External Subroutines .. + EXTERNAL DLANV2, DLARFG, DLASET, DLASV2, DLATZM, DROT +C .. Intrinsic Functions .. + INTRINSIC ABS, MIN +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked. +C + INFO = 0 + IF( N.EQ.1 ) THEN +C +C The case N = 1. +C + IF( M.GT.1 ) + $ CALL DLARFG( M, B(1,1), B(1,2), N, TAU1 ) + B1 = B(1,1) + IF( ABS( B1 ).LE.TOL ) THEN +C +C The pair (A,B) is uncontrollable. +C + INFO = 1 + RETURN + END IF +C + F(1,1) = ( S - A(1,1) )/B1 + IF( M.GT.1 ) THEN + CALL DLASET( 'Full', M-1, 1, ZERO, ZERO, F(2,1), M ) + CALL DLATZM( 'Left', M, N, B(1,2), N, TAU1, F(1,1), F(2,1), + $ M, DWORK ) + END IF + RETURN + END IF +C +C In the sequel N = 2. +C +C Compute the singular value decomposition of B in the form +C +C ( V 0 ) ( B1 0 ) +C B = U*( G1 0 )*( )*H2*H1 , G1 = ( ), +C ( 0 I ) ( 0 B2 ) +C +C ( CU SU ) ( CV SV ) +C where U = ( ) and V = ( ) are orthogonal +C (-SU CU ) (-SV CV ) +C +C rotations and H1 and H2 are elementary Householder reflectors. +C ABS(B1) and ABS(B2) are the singular values of matrix B, +C with ABS(B1) >= ABS(B2). +C +C Reduce first B to the lower bidiagonal form ( B1 0 ... 0 ). +C ( B21 B2 ... 0 ) + IF( M.EQ.1 ) THEN +C +C Initialization for the case M = 1; no reduction required. +C + B1 = B(1,1) + B21 = B(2,1) + B2 = ZERO + ELSE +C +C Postmultiply B with elementary Householder reflectors H1 +C and H2. +C + CALL DLARFG( M, B(1,1), B(1,2), N, TAU1 ) + CALL DLATZM( 'Right', N-1, M, B(1,2), N, TAU1, B(2,1), B(2,2), + $ N, DWORK ) + B1 = B(1,1) + B21 = B(2,1) + IF( M.GT.2 ) + $ CALL DLARFG( M-1, B(2,2), B(2,3), N, TAU2 ) + B2 = B(2,2) + END IF +C +C Reduce B to a diagonal form by premultiplying and postmultiplying +C it with orthogonal rotations U and V, respectively, and order the +C diagonal elements to have decreasing magnitudes. +C Note: B2 has been set to zero if M = 1. Thus in the following +C computations the case M = 1 need not to be distinguished. +C Note also that LAPACK routine DLASV2 assumes an upper triangular +C matrix, so the results should be adapted. +C + CALL DLASV2( B1, B21, B2, X, Y, SU, CU, SV, CV ) + SU = -SU + B1 = Y + B2 = X +C +C Compute A1 = U'*A*U. +C + CALL DROT( 2, A(2,1), 2, A(1,1), 2, CU, SU ) + CALL DROT( 2, A(1,2), 1, A(1,1), 1, CU, SU ) +C +C Compute the rank of B and check the controllability of the +C pair (A,B). +C + IR = 0 + IF( ABS( B2 ).GT.TOL ) IR = IR + 1 + IF( ABS( B1 ).GT.TOL ) IR = IR + 1 + IF( IR.EQ.0 .OR. ( IR.EQ.1 .AND. ABS( A(2,1) ).LE.TOL ) ) THEN + F(1,1) = CU + F(1,2) = -SU +C +C The pair (A,B) is uncontrollable. +C + INFO = 1 + RETURN + END IF +C +C Compute F1 which assigns N poles for the reduced pair (A1,G1). +C + X = DLAMC3( B1, B2 ) + IF( X.EQ.B1 ) THEN +C +C Rank one G1. +C + F(1,1) = ( S - ( A(1,1) + A(2,2) ) )/B1 + F(1,2) = -( A(2,2)*( A(2,2) - S ) + A(2,1)*A(1,2) + P )/ + $ A(2,1)/B1 + IF( M.GT.1 ) THEN + F(2,1) = ZERO + F(2,2) = ZERO + END IF + ELSE +C +C Rank two G1. +C + Z = ( S - ( A(1,1) + A(2,2) ) )/( B1*B1 + B2*B2 ) + F(1,1) = B1*Z + F(2,2) = B2*Z +C +C Compute an approximation for the minimum norm parameter +C selection. +C + X = A(1,1) + B1*F(1,1) + C = X*( S - X ) - P + IF( C.GE.ZERO ) THEN + SIG = ONE + ELSE + SIG = -ONE + END IF + S12 = B1/B2 + S21 = B2/B1 + C11 = ZERO + C12 = ONE + C21 = SIG*S12*C + C22 = A(1,2) - SIG*S12*A(2,1) + CALL DLANV2( C11, C12, C21, C22, WR, WI, WR1, WI1, CS, SN ) + IF( ABS( WR - A(1,2) ).GT.ABS( WR1 - A(1,2) ) ) THEN + R = WR1 + ELSE + R = WR + END IF +C +C Perform Newton iteration to solve the equation for minimum. +C + C0 = -C*C + C1 = C*A(2,1) + C4 = S21*S21 + C3 = -C4*A(1,2) + DC0 = C1 + DC2 = THREE*C3 + DC3 = FOUR*C4 +C + DO 10 J = 1, 10 + X = C0 + R*( C1 + R*R*( C3 + R*C4 ) ) + Y = DC0 + R*R*( DC2 + R*DC3 ) + IF( Y.EQ.ZERO ) GO TO 20 + RN = R - X/Y + ABSR = ABS( R ) + DIFFR = ABS( R - RN ) + Z = DLAMC3( ABSR, DIFFR ) + IF( Z.EQ.ABSR ) + $ GO TO 20 + R = RN + 10 CONTINUE +C + 20 CONTINUE + IF( R.EQ.ZERO ) R = DLAMCH( 'Epsilon' ) + F(1,2) = ( R - A(1,2) )/B1 + F(2,1) = ( C/R - A(2,1) )/B2 + END IF +C +C Back-transform F1. Compute first F1*U'. +C + CALL DROT( MIN( M, 2 ), F(1,1), 1, F(1,2), 1, CU, SU ) + IF( M.EQ.1 ) + $ RETURN +C +C Compute V'*F1. +C + CALL DROT( 2, F(2,1), M, F(1,1), M, CV, SV ) +C +C ( F1 ) +C Form F = ( ) . +C ( 0 ) +C + IF( M.GT.N ) + $ CALL DLASET( 'Full', M-N, N, ZERO, ZERO, F(N+1,1), M ) +C +C Compute H1*H2*F. +C + IF( M.GT.2 ) + $ CALL DLATZM( 'Left', M-1, N, B(2,3), N, TAU2, F(2,1), F(3,1), + $ M, DWORK ) + CALL DLATZM( 'Left', M, N, B(1,2), N, TAU1, F(1,1), F(2,1), M, + $ DWORK ) +C + RETURN +C *** Last line of SB01BY *** + END Added: trunk/octave-forge/extra/control-oo/src/slsb01bd.cc =================================================================== --- trunk/octave-forge/extra/control-oo/src/slsb01bd.cc (rev 0) +++ trunk/octave-forge/extra/control-oo/src/slsb01bd.cc 2009-12-04 16:21:11 UTC (rev 6594) @@ -0,0 +1,159 @@ +/* + +Copyright (C) 2009 Lukas F. Reichlin + +This file is part of LTI Syncope. + +LTI Syncope 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. + +LTI Syncope 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, see <http://www.gnu.org/licenses/>. + +Pole assignment for a given matrix pair (A,B). +Uses SLICOT SB01BD by courtesy of NICONET e.V. +<http://www.slicot.org> + +Author: Lukas Reichlin <luk...@gm...> +Created: November 2009 +Version: 0.1 + +*/ + +#include <octave/oct.h> +#include <f77-fcn.h> + +extern "C" +{ + int F77_FUNC (sb01bd, SB01BD) + (char& DICO, + int& N, int& M, int& NP, + double& ALPHA, + double* A, int& LDA, + double* B, int& LDB, + double* WR, double* WI, + int& NFP, int& NAP, int& NUP, + double* F, int& LDF, + double* Z, int& LDZ, + double& TOL, + double* DWORK, int& LDWORK, + int& IWARN, int& INFO); +} + +int max (int a, int b) +{ + if (a > b) + return a; + else + return b; +} + +int max (int a, int b, int c, int d) +{ + int e = max (a, b); + int f = max (c, d); + + if (e > f) + return e; + else + return f; +} + +DEFUN_DLD (slsb01bd, args, nargout, "Slicot SB01BD Release 5.0") +{ + int nargin = args.length (); + octave_value_list retval; + + if (nargin != 6) + { + print_usage (); + } + else + { + // arguments in + char dico; + + NDArray a = args(0).array_value (); + NDArray b = args(1).array_value (); + NDArray wr = args(2).array_value (); + NDArray wi = args(3).array_value (); + double tsam = args(4).double_value (); + double alpha = args(5).double_value (); + + if (tsam > 0) + dico = 'D'; + else + dico = 'C'; + + int n = a.rows (); // n: number of states + int m = b.columns (); // m: number of inputs + int np = wr.rows (); + + int lda = max (1, a.rows ()); + int ldb = max (1, b.rows ()); + int ldf = max (1, m); + int ldz = max (1, n); + + double tol = 0; + + // arguments out + int nfp; + int nap; + int nup; + + dim_vector dv (2); + dv(0) = ldf; + dv(1) = n; + NDArray f (dv); + + double* z; + z = new double[ldz*n]; + + // workspace + double* dwork; + int ldwork = max (1, 5*m, 5*n, 2*n+4*m); + dwork = new double[ldwork]; + + // error indicators + int iwarn; + int info; + + + // SLICOT routine AB13DD + F77_XFCN (sb01bd, SB01BD, + (dico, + n, m, np, + alpha, + a.fortran_vec (), lda, + b.fortran_vec (), ldb, + wr.fortran_vec (), wi.fortran_vec (), + nfp, nap, nup, + f.fortran_vec (), ldf, + z, ldz, + tol, + dwork, ldwork, + iwarn, info)); + + if (f77_exception_encountered) + error ("place: slsb01bd: exception in SLICOT subroutine SB01BD"); + + if (info != 0) + error ("place: slsb01bd: SB01BD returned info = %d", info); + + // return values + retval(0) = f; + retval(1) = octave_value (iwarn); + + // free memory + delete[] dwork; + } + + return retval; +} This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <par...@us...> - 2009-12-05 07:27:30
|
Revision: 6598 http://octave.svn.sourceforge.net/octave/?rev=6598&view=rev Author: paramaniac Date: 2009-12-05 07:27:20 +0000 (Sat, 05 Dec 2009) Log Message: ----------- control-oo: hinfsyn was in the wrong folder Added Paths: ----------- trunk/octave-forge/extra/control-oo/inst/hinfsyn.m Removed Paths: ------------- trunk/octave-forge/extra/control-oo/src/hinfsyn.m Copied: trunk/octave-forge/extra/control-oo/inst/hinfsyn.m (from rev 6597, trunk/octave-forge/extra/control-oo/src/hinfsyn.m) =================================================================== --- trunk/octave-forge/extra/control-oo/inst/hinfsyn.m (rev 0) +++ trunk/octave-forge/extra/control-oo/inst/hinfsyn.m 2009-12-05 07:27:20 UTC (rev 6598) @@ -0,0 +1,202 @@ +## Copyright (C) 2009 Lukas F. Reichlin +## +## This file is part of LTI Syncope. +## +## LTI Syncope 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. +## +## LTI Syncope 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, see <http://www.gnu.org/licenses/>. + +## -*- texinfo -*- +## @deftypefn{Function File} {[@var{K}, @var{T}, @var{gamma}] =} hinfsyn (@var{P}, @var{nmeas}, @var{ncon}) +## @deftypefnx{Function File} {[@var{K}, @var{T}, @var{gamma}] =} hinfsyn (@var{P}, @var{nmeas}, @var{ncon}, @var{gamma}) +## H-infinity control synthesis for LTI plant. +## Uses SLICOT SB10FD and SB10DD by courtesy of NICONET e.V. +## <http://www.slicot.org> +## @end deftypefn + +## Author: Lukas Reichlin <luk...@gm...> +## Created: December 2009 +## Version: 0.1 + +function [K, varargout] = hinfsyn (P, nmeas, ncon, gmax = 1e6) + + ## check input arguments + if (nargin < 3 || nargin > 4) + print_usage (); + endif + + if (! isa (P, "lti")) + error ("hinfsyn: first argument must be a LTI system"); + endif + + if (! isscalar (nmeas) || ! isnumeric (nmeas) || isempty (nmeas)) + error ("hinfsyn: second argument invalid"); + endif + + if (! isscalar (ncon) || ! isnumeric (ncon) || isempty (ncon)) + error ("hinfsyn: third argument invalid"); + endif + + if (! isscalar (gmax) || ! isnumeric (gmax) || isempty (gmax) || gmax < 0) + error ("hinfsyn: fourth argument invalid"); + endif + + [a, b, c, d, tsam] = ssdata (P); + + ## check assumption A1 + m = columns (b); + p = rows (c); + + m1 = m - ncon; + p1 = p - nmeas; + + if (! isstabilizable (P(:, m1+1 : m))) + error ("hinfsyn: (A, B2) must be stabilizable"); + endif + + if (! isdetectable (P(p1+1 : p, :))) + error ("hinfsyn: (A, C2) must be detectable"); + endif + + ## H-infinity synthesis + if (tsam > 0) # discrete plant + [ak, bk, ck, dk] = slsb10dd (a, b, c, d, ncon, nmeas, gmax); + else # continuous plant + [ak, bk, ck, dk] = slsb10fd (a, b, c, d, ncon, nmeas, gmax); + endif + + ## controller + K = ss (ak, bk, ck, dk, tsam); + + if (nargout > 1) + T = lft (P, K); + varargout{1} = T; + if (nargout > 2) + varargout{2} = norm (T); + endif + endif + +endfunction + + +## continuous-time case +%!shared M, M_exp +%! A = [-1.0 0.0 4.0 5.0 -3.0 -2.0 +%! -2.0 4.0 -7.0 -2.0 0.0 3.0 +%! -6.0 9.0 -5.0 0.0 2.0 -1.0 +%! -8.0 4.0 7.0 -1.0 -3.0 0.0 +%! 2.0 5.0 8.0 -9.0 1.0 -4.0 +%! 3.0 -5.0 8.0 0.0 2.0 -6.0]; +%! +%! B = [-3.0 -4.0 -2.0 1.0 0.0 +%! 2.0 0.0 1.0 -5.0 2.0 +%! -5.0 -7.0 0.0 7.0 -2.0 +%! 4.0 -6.0 1.0 1.0 -2.0 +%! -3.0 9.0 -8.0 0.0 5.0 +%! 1.0 -2.0 3.0 -6.0 -2.0]; +%! +%! C = [ 1.0 -1.0 2.0 -4.0 0.0 -3.0 +%! -3.0 0.0 5.0 -1.0 1.0 1.0 +%! -7.0 5.0 0.0 -8.0 2.0 -2.0 +%! 9.0 -3.0 4.0 0.0 3.0 7.0 +%! 0.0 1.0 -2.0 1.0 -6.0 -2.0]; +%! +%! D = [ 1.0 -2.0 -3.0 0.0 0.0 +%! 0.0 4.0 0.0 1.0 0.0 +%! 5.0 -3.0 -4.0 0.0 1.0 +%! 0.0 1.0 0.0 1.0 -3.0 +%! 0.0 0.0 1.0 7.0 1.0]; +%! +%! P = ss (A, B, C, D); +%! K = hinfsyn (P, 2, 2, 15); +%! M = [K.A, K.B; K.C, K.D]; +%! +%! KA = [ -2.8043 14.7367 4.6658 8.1596 0.0848 2.5290 +%! 4.6609 3.2756 -3.5754 -2.8941 0.2393 8.2920 +%! -15.3127 23.5592 -7.1229 2.7599 5.9775 -2.0285 +%! -22.0691 16.4758 12.5523 -16.3602 4.4300 -3.3168 +%! 30.6789 -3.9026 -1.3868 26.2357 -8.8267 10.4860 +%! -5.7429 0.0577 10.8216 -11.2275 1.5074 -10.7244]; +%! +%! KB = [ -0.1581 -0.0793 +%! -0.9237 -0.5718 +%! 0.7984 0.6627 +%! 0.1145 0.1496 +%! -0.6743 -0.2376 +%! 0.0196 -0.7598]; +%! +%! KC = [ -0.2480 -0.1713 -0.0880 0.1534 0.5016 -0.0730 +%! 2.8810 -0.3658 1.3007 0.3945 1.2244 2.5690]; +%! +%! KD = [ 0.0554 0.1334 +%! -0.3195 0.0333]; +%! +%! M_exp = [KA, KB; KC, KD]; +%! +%!assert (M, M_exp, 1e-4); + + +## discrete-time case +%!shared M, M_exp +%! A = [-0.7 0.0 0.3 0.0 -0.5 -0.1 +%! -0.6 0.2 -0.4 -0.3 0.0 0.0 +%! -0.5 0.7 -0.1 0.0 0.0 -0.8 +%! -0.7 0.0 0.0 -0.5 -1.0 0.0 +%! 0.0 0.3 0.6 -0.9 0.1 -0.4 +%! 0.5 -0.8 0.0 0.0 0.2 -0.9]; +%! +%! B = [-1.0 -2.0 -2.0 1.0 0.0 +%! 1.0 0.0 1.0 -2.0 1.0 +%! -3.0 -4.0 0.0 2.0 -2.0 +%! 1.0 -2.0 1.0 0.0 -1.0 +%! 0.0 1.0 -2.0 0.0 3.0 +%! 1.0 0.0 3.0 -1.0 -2.0]; +%! +%! C = [ 1.0 -1.0 2.0 -2.0 0.0 -3.0 +%! -3.0 0.0 1.0 -1.0 1.0 0.0 +%! 0.0 2.0 0.0 -4.0 0.0 -2.0 +%! 1.0 -3.0 0.0 0.0 3.0 1.0 +%! 0.0 1.0 -2.0 1.0 0.0 -2.0]; +%! +%! D = [ 1.0 -1.0 -2.0 0.0 0.0 +%! 0.0 1.0 0.0 1.0 0.0 +%! 2.0 -1.0 -3.0 0.0 1.0 +%! 0.0 1.0 0.0 1.0 -1.0 +%! 0.0 0.0 1.0 2.0 1.0]; +%! +%! P = ss (A, B, C, D, 1); # value of sampling time doesn't matter +%! K = hinfsyn (P, 2, 2, 111.294); +%! M = [K.A, K.B; K.C, K.D]; +%! +%! KA = [-18.0030 52.0376 26.0831 -0.4271 -40.9022 18.0857 +%! 18.8203 -57.6244 -29.0938 0.5870 45.3309 -19.8644 +%! -26.5994 77.9693 39.0368 -1.4020 -60.1129 26.6910 +%! -21.4163 62.1719 30.7507 -0.9201 -48.6221 21.8351 +%! -0.8911 4.2787 2.3286 -0.2424 -3.0376 1.2169 +%! -5.3286 16.1955 8.4824 -0.2489 -12.2348 5.1590]; +%! +%! KB = [ 16.9788 14.1648 +%! -18.9215 -15.6726 +%! 25.2046 21.2848 +%! 20.1122 16.8322 +%! 1.4104 1.2040 +%! 5.3181 4.5149]; +%! +%! KC = [ -9.1941 27.5165 13.7364 -0.3639 -21.5983 9.6025 +%! 3.6490 -10.6194 -5.2772 0.2432 8.1108 -3.6293]; +%! +%! KD = [ 9.0317 7.5348 +%! -3.4006 -2.8219]; +%! +%! M_exp = [KA, KB; KC, KD]; +%! +%!assert (M, M_exp, 1e-4); \ No newline at end of file Deleted: trunk/octave-forge/extra/control-oo/src/hinfsyn.m =================================================================== --- trunk/octave-forge/extra/control-oo/src/hinfsyn.m 2009-12-04 20:07:40 UTC (rev 6597) +++ trunk/octave-forge/extra/control-oo/src/hinfsyn.m 2009-12-05 07:27:20 UTC (rev 6598) @@ -1,202 +0,0 @@ -## Copyright (C) 2009 Lukas F. Reichlin -## -## This file is part of LTI Syncope. -## -## LTI Syncope 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. -## -## LTI Syncope 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, see <http://www.gnu.org/licenses/>. - -## -*- texinfo -*- -## @deftypefn{Function File} {[@var{K}, @var{T}, @var{gamma}] =} hinfsyn (@var{P}, @var{nmeas}, @var{ncon}) -## @deftypefnx{Function File} {[@var{K}, @var{T}, @var{gamma}] =} hinfsyn (@var{P}, @var{nmeas}, @var{ncon}, @var{gamma}) -## H-infinity control synthesis for LTI plant. -## Uses SLICOT SB10FD and SB10DD by courtesy of NICONET e.V. -## <http://www.slicot.org> -## @end deftypefn - -## Author: Lukas Reichlin <luk...@gm...> -## Created: December 2009 -## Version: 0.1 - -function [K, varargout] = hinfsyn (P, nmeas, ncon, gmax = 1e6) - - ## check input arguments - if (nargin < 3 || nargin > 4) - print_usage (); - endif - - if (! isa (P, "lti")) - error ("hinfsyn: first argument must be a LTI system"); - endif - - if (! isscalar (nmeas) || ! isnumeric (nmeas) || isempty (nmeas)) - error ("hinfsyn: second argument invalid"); - endif - - if (! isscalar (ncon) || ! isnumeric (ncon) || isempty (ncon)) - error ("hinfsyn: third argument invalid"); - endif - - if (! isscalar (gmax) || ! isnumeric (gmax) || isempty (gmax) || gmax < 0) - error ("hinfsyn: fourth argument invalid"); - endif - - [a, b, c, d, tsam] = ssdata (P); - - ## check assumption A1 - m = columns (b); - p = rows (c); - - m1 = m - ncon; - p1 = p - nmeas; - - if (! isstabilizable (P(:, m1+1 : m))) - error ("hinfsyn: (A, B2) must be stabilizable"); - endif - - if (! isdetectable (P(p1+1 : p, :))) - error ("hinfsyn: (A, C2) must be detectable"); - endif - - ## H-infinity synthesis - if (tsam > 0) # discrete plant - [ak, bk, ck, dk] = slsb10dd (a, b, c, d, ncon, nmeas, gmax); - else # continuous plant - [ak, bk, ck, dk] = slsb10fd (a, b, c, d, ncon, nmeas, gmax); - endif - - ## controller - K = ss (ak, bk, ck, dk, tsam); - - if (nargout > 1) - T = lft (P, K); - varargout{1} = T; - if (nargout > 2) - varargout{2} = norm (T); - endif - endif - -endfunction - - -## continuous-time case -%!shared M, M_exp -%! A = [-1.0 0.0 4.0 5.0 -3.0 -2.0 -%! -2.0 4.0 -7.0 -2.0 0.0 3.0 -%! -6.0 9.0 -5.0 0.0 2.0 -1.0 -%! -8.0 4.0 7.0 -1.0 -3.0 0.0 -%! 2.0 5.0 8.0 -9.0 1.0 -4.0 -%! 3.0 -5.0 8.0 0.0 2.0 -6.0]; -%! -%! B = [-3.0 -4.0 -2.0 1.0 0.0 -%! 2.0 0.0 1.0 -5.0 2.0 -%! -5.0 -7.0 0.0 7.0 -2.0 -%! 4.0 -6.0 1.0 1.0 -2.0 -%! -3.0 9.0 -8.0 0.0 5.0 -%! 1.0 -2.0 3.0 -6.0 -2.0]; -%! -%! C = [ 1.0 -1.0 2.0 -4.0 0.0 -3.0 -%! -3.0 0.0 5.0 -1.0 1.0 1.0 -%! -7.0 5.0 0.0 -8.0 2.0 -2.0 -%! 9.0 -3.0 4.0 0.0 3.0 7.0 -%! 0.0 1.0 -2.0 1.0 -6.0 -2.0]; -%! -%! D = [ 1.0 -2.0 -3.0 0.0 0.0 -%! 0.0 4.0 0.0 1.0 0.0 -%! 5.0 -3.0 -4.0 0.0 1.0 -%! 0.0 1.0 0.0 1.0 -3.0 -%! 0.0 0.0 1.0 7.0 1.0]; -%! -%! P = ss (A, B, C, D); -%! K = hinfsyn (P, 2, 2, 15); -%! M = [K.A, K.B; K.C, K.D]; -%! -%! KA = [ -2.8043 14.7367 4.6658 8.1596 0.0848 2.5290 -%! 4.6609 3.2756 -3.5754 -2.8941 0.2393 8.2920 -%! -15.3127 23.5592 -7.1229 2.7599 5.9775 -2.0285 -%! -22.0691 16.4758 12.5523 -16.3602 4.4300 -3.3168 -%! 30.6789 -3.9026 -1.3868 26.2357 -8.8267 10.4860 -%! -5.7429 0.0577 10.8216 -11.2275 1.5074 -10.7244]; -%! -%! KB = [ -0.1581 -0.0793 -%! -0.9237 -0.5718 -%! 0.7984 0.6627 -%! 0.1145 0.1496 -%! -0.6743 -0.2376 -%! 0.0196 -0.7598]; -%! -%! KC = [ -0.2480 -0.1713 -0.0880 0.1534 0.5016 -0.0730 -%! 2.8810 -0.3658 1.3007 0.3945 1.2244 2.5690]; -%! -%! KD = [ 0.0554 0.1334 -%! -0.3195 0.0333]; -%! -%! M_exp = [KA, KB; KC, KD]; -%! -%!assert (M, M_exp, 1e-4); - - -## discrete-time case -%!shared M, M_exp -%! A = [-0.7 0.0 0.3 0.0 -0.5 -0.1 -%! -0.6 0.2 -0.4 -0.3 0.0 0.0 -%! -0.5 0.7 -0.1 0.0 0.0 -0.8 -%! -0.7 0.0 0.0 -0.5 -1.0 0.0 -%! 0.0 0.3 0.6 -0.9 0.1 -0.4 -%! 0.5 -0.8 0.0 0.0 0.2 -0.9]; -%! -%! B = [-1.0 -2.0 -2.0 1.0 0.0 -%! 1.0 0.0 1.0 -2.0 1.0 -%! -3.0 -4.0 0.0 2.0 -2.0 -%! 1.0 -2.0 1.0 0.0 -1.0 -%! 0.0 1.0 -2.0 0.0 3.0 -%! 1.0 0.0 3.0 -1.0 -2.0]; -%! -%! C = [ 1.0 -1.0 2.0 -2.0 0.0 -3.0 -%! -3.0 0.0 1.0 -1.0 1.0 0.0 -%! 0.0 2.0 0.0 -4.0 0.0 -2.0 -%! 1.0 -3.0 0.0 0.0 3.0 1.0 -%! 0.0 1.0 -2.0 1.0 0.0 -2.0]; -%! -%! D = [ 1.0 -1.0 -2.0 0.0 0.0 -%! 0.0 1.0 0.0 1.0 0.0 -%! 2.0 -1.0 -3.0 0.0 1.0 -%! 0.0 1.0 0.0 1.0 -1.0 -%! 0.0 0.0 1.0 2.0 1.0]; -%! -%! P = ss (A, B, C, D, 1); # value of sampling time doesn't matter -%! K = hinfsyn (P, 2, 2, 111.294); -%! M = [K.A, K.B; K.C, K.D]; -%! -%! KA = [-18.0030 52.0376 26.0831 -0.4271 -40.9022 18.0857 -%! 18.8203 -57.6244 -29.0938 0.5870 45.3309 -19.8644 -%! -26.5994 77.9693 39.0368 -1.4020 -60.1129 26.6910 -%! -21.4163 62.1719 30.7507 -0.9201 -48.6221 21.8351 -%! -0.8911 4.2787 2.3286 -0.2424 -3.0376 1.2169 -%! -5.3286 16.1955 8.4824 -0.2489 -12.2348 5.1590]; -%! -%! KB = [ 16.9788 14.1648 -%! -18.9215 -15.6726 -%! 25.2046 21.2848 -%! 20.1122 16.8322 -%! 1.4104 1.2040 -%! 5.3181 4.5149]; -%! -%! KC = [ -9.1941 27.5165 13.7364 -0.3639 -21.5983 9.6025 -%! 3.6490 -10.6194 -5.2772 0.2432 8.1108 -3.6293]; -%! -%! KD = [ 9.0317 7.5348 -%! -3.4006 -2.8219]; -%! -%! M_exp = [KA, KB; KC, KD]; -%! -%!assert (M, M_exp, 1e-4); \ No newline at end of file This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <par...@us...> - 2009-12-04 19:53:29
|
Revision: 6595 http://octave.svn.sourceforge.net/octave/?rev=6595&view=rev Author: paramaniac Date: 2009-12-04 19:53:15 +0000 (Fri, 04 Dec 2009) Log Message: ----------- control-oo: add hinfsyn Modified Paths: -------------- trunk/octave-forge/extra/control-oo/DESCRIPTION trunk/octave-forge/extra/control-oo/INDEX trunk/octave-forge/extra/control-oo/src/Makefile Added Paths: ----------- trunk/octave-forge/extra/control-oo/src/SB10DD.f trunk/octave-forge/extra/control-oo/src/SB10FD.f trunk/octave-forge/extra/control-oo/src/SB10QD.f trunk/octave-forge/extra/control-oo/src/SB10RD.f trunk/octave-forge/extra/control-oo/src/hinfsyn.m trunk/octave-forge/extra/control-oo/src/slsb10dd.cc trunk/octave-forge/extra/control-oo/src/slsb10fd.cc Modified: trunk/octave-forge/extra/control-oo/DESCRIPTION =================================================================== --- trunk/octave-forge/extra/control-oo/DESCRIPTION 2009-12-04 16:21:11 UTC (rev 6594) +++ trunk/octave-forge/extra/control-oo/DESCRIPTION 2009-12-04 19:53:15 UTC (rev 6595) @@ -1,6 +1,6 @@ Name: Control -Version: 0.2.1 -Date: 2009-12-02 +Version: 0.2.2 +Date: 2009-12-04 Author: Lukas Reichlin <luk...@gm...> Maintainer: Luca Favatella <sla...@gm...> Title: LTI Syncope Modified: trunk/octave-forge/extra/control-oo/INDEX =================================================================== --- trunk/octave-forge/extra/control-oo/INDEX 2009-12-04 16:21:11 UTC (rev 6594) +++ trunk/octave-forge/extra/control-oo/INDEX 2009-12-04 19:53:15 UTC (rev 6595) @@ -52,6 +52,7 @@ lqr Controller Synthesis h2syn + hinfsyn State-Space Models ctrb gram Modified: trunk/octave-forge/extra/control-oo/src/Makefile =================================================================== --- trunk/octave-forge/extra/control-oo/src/Makefile 2009-12-04 16:21:11 UTC (rev 6594) +++ trunk/octave-forge/extra/control-oo/src/Makefile 2009-12-04 19:53:15 UTC (rev 6595) @@ -1,4 +1,5 @@ -all: slab08nd.oct slab13dd.oct slsb10hd.oct slsb10ed.oct slab13bd.oct slsb01bd.oct +all: slab08nd.oct slab13dd.oct slsb10hd.oct slsb10ed.oct slab13bd.oct \ + slsb01bd.oct slsb10fd.oct slsb10dd.oct # transmission zeros of state-space models slab08nd.oct: slab08nd.cc @@ -48,5 +49,24 @@ SB01BD.f MB03QD.f MB03QY.f SB01BX.f SB01BY.f \ select.f +# H-inf controller synthesis - continuous-time +slsb10fd.oct: slsb10fd.cc + mkoctfile slsb10fd.cc \ + SB10FD.f SB10PD.f SB10QD.f SB10RD.f SB02RD.f \ + MB01RU.f MB01RX.f MA02AD.f SB02SD.f MA02ED.f \ + SB02RU.f SB02MR.f MB01SD.f SB02MS.f SB02MV.f \ + SB02MW.f SB02QD.f MB02PD.f SB03QX.f SB03QY.f \ + MB01RY.f SB03SX.f SB03SY.f select.f SB03MX.f \ + SB03MY.f MB01UD.f SB03MV.f SB03MW.f SB04PX.f + +# H-inf controller synthesis - discrete-time +slsb10dd.oct: slsb10dd.cc + mkoctfile slsb10dd.cc \ + SB10DD.f MB01RU.f MB01RX.f SB02SD.f SB02OD.f \ + MA02AD.f SB02OU.f SB02OV.f SB02OW.f MB01RY.f \ + SB02OY.f SB03SX.f SB03SY.f MA02ED.f select.f \ + SB03MX.f SB02MR.f SB02MV.f MB01UD.f SB03MV.f \ + SB04PX.f + clean: rm *.o core octave-core *.oct *~ Added: trunk/octave-forge/extra/control-oo/src/SB10DD.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/SB10DD.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/SB10DD.f 2009-12-04 19:53:15 UTC (rev 6595) @@ -0,0 +1,1007 @@ + SUBROUTINE SB10DD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, + $ C, LDC, D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, + $ DK, LDDK, X, LDX, Z, LDZ, RCOND, TOL, IWORK, + $ DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To compute the matrices of an H-infinity (sub)optimal n-state +C controller +C +C | AK | BK | +C K = |----|----|, +C | CK | DK | +C +C for the discrete-time system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 D22 | +C +C and for a given value of gamma, where B2 has as column size the +C number of control inputs (NCON) and C2 has as row size the number +C of measurements (NMEAS) being provided to the controller. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank and D21 is full row rank, +C +C j*Theta +C (A3) | A-e *I B2 | has full column rank for all +C | C1 D12 | +C +C 0 <= Theta < 2*Pi , +C +C j*Theta +C (A4) | A-e *I B1 | has full row rank for all +C | C2 D21 | +C +C 0 <= Theta < 2*Pi . +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C GAMMA (input) DOUBLE PRECISION +C The value of gamma. It is assumed that gamma is +C sufficiently large so that the controller is admissible. +C GAMMA > 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array contains the matrix +C X, solution of the X-Riccati equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C The leading N-by-N part of this array contains the matrix +C Z, solution of the Z-Riccati equation. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= max(1,N). +C +C RCOND (output) DOUBLE PRECISION array, dimension (8) +C RCOND contains estimates of the reciprocal condition +C numbers of the matrices which are to be inverted and +C estimates of the reciprocal condition numbers of the +C Riccati equations which have to be solved during the +C computation of the controller. (See the description of +C the algorithm in [2].) +C RCOND(1) contains the reciprocal condition number of the +C matrix R3; +C RCOND(2) contains the reciprocal condition number of the +C matrix R1 - R2'*inv(R3)*R2; +C RCOND(3) contains the reciprocal condition number of the +C matrix V21; +C RCOND(4) contains the reciprocal condition number of the +C matrix St3; +C RCOND(5) contains the reciprocal condition number of the +C matrix V12; +C RCOND(6) contains the reciprocal condition number of the +C matrix Im2 + DKHAT*D22 +C RCOND(7) contains the reciprocal condition number of the +C X-Riccati equation; +C RCOND(8) contains the reciprocal condition number of the +C Z-Riccati equation. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used in neglecting the small singular values +C in rank determination. If TOL <= 0, then a default value +C equal to 1000*EPS is used, where EPS is the relative +C machine precision. +C +C Workspace +C +C IWORK INTEGER array, dimension max(2*max(M2,N),M,M2+NP2,N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= max(LW1,LW2,LW3,LW4), where +C LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2)); +C LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2)); +C LW3 = 13*N*N + 2*M*M + N*(8*M+NP2) + M1*(M2+NP2) + 6*N + +C max(14*N+23,16*N,2*N+M,3*M); +C LW4 = 13*N*N + M*M + (8*N+M+M2+2*NP2)*(M2+NP2) + 6*N + +C N*(M+NP2) + max(14*N+23,16*N,2*N+M2+NP2,3*(M2+NP2)); +C For good performance, LDWORK must generally be larger. +C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is +C max((N+Q)*(N+Q+6),13*N*N + M*M + 2*Q*Q + N*(M+Q) + +C max(M*(M+7*N),2*Q*(8*N+M+2*Q)) + 6*N + +C max(14*N+23,16*N,2*N+max(M,2*Q),3*max(M,2*Q)). +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C j*Theta +C = 1: if the matrix | A-e *I B2 | had not full +C | C1 D12 | +C column rank; +C j*Theta +C = 2: if the matrix | A-e *I B1 | had not full +C | C2 D21 | +C row rank; +C = 3: if the matrix D12 had not full column rank; +C = 4: if the matrix D21 had not full row rank; +C = 5: if the controller is not admissible (too small value +C of gamma); +C = 6: if the X-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 7: if the Z-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 8: if the matrix Im2 + DKHAT*D22 is singular. +C = 9: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of one of +C the matrices |A B2 |, |A B1 |, D12 or D21). +C |C1 D12| |C2 D21| +C +C METHOD +C +C The routine implements the method presented in [1]. +C +C REFERENCES +C +C [1] Green, M. and Limebeer, D.J.N. +C Linear Robust Control. +C Prentice-Hall, Englewood Cliffs, NJ, 1995. +C +C [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of linear +C discrete-time control systems. +C Report 99-8, Department of Engineering, Leicester University, +C April 1999. +C +C NUMERICAL ASPECTS +C +C With approaching the minimum value of gamma some of the matrices +C which are to be inverted tend to become ill-conditioned and +C the X- or Z-Riccati equation may also become ill-conditioned +C which may deteriorate the accuracy of the result. (The +C corresponding reciprocal condition numbers are given in +C the output array RCOND.) +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, April 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Sep. 1999. +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2000. +C +C KEYWORDS +C +C Algebraic Riccati equation, discrete-time H-infinity optimal +C control, robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, THOUSN + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, + $ THOUSN = 1.0D+3 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDWORK, LDX, LDZ, M, N, NCON, NMEAS, NP + DOUBLE PRECISION GAMMA, TOL +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ RCOND( * ), X( LDX, * ), Z( LDZ, * ) + LOGICAL BWORK( * ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IR2, IR3, IS2, IS3, IWB, IWC, IWD, IWG, + $ IWH, IWI, IWL, IWQ, IWR, IWRK, IWS, IWT, IWU, + $ IWV, IWW, J, LWAMAX, M1, M2, MINWRK, NP1, NP2 + DOUBLE PRECISION ANORM, FERR, RCOND2, SEPD, TOLL +C +C .. External Functions + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANSY +C .. +C .. External Subroutines .. + EXTERNAL DGECON, DGEMM, DGESVD, DGETRF, DGETRS, DLACPY, + $ DLASET, DPOCON, DPOTRF, DSCAL, DSWAP, DSYRK, + $ DSYTRF, DSYTRS, DTRCON, DTRSM, MA02AD, MB01RU, + $ MB01RX, SB02OD, SB02SD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( GAMMA.LE.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -14 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -20 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -22 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -24 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -26 + ELSE +C +C Compute workspace. +C + IWB = ( N + NP1 + 1 )*( N + M2 ) + + $ MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ) + IWC = ( N + NP2 )*( N + M1 + 1 ) + + $ MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ) + IWD = 13*N*N + 2*M*M + N*( 8*M + NP2 ) + M1*( M2 + NP2 ) + + $ 6*N + MAX( 14*N + 23, 16*N, 2*N + M, 3*M ) + IWG = 13*N*N + M*M + ( 8*N + M + M2 + 2*NP2 )*( M2 + NP2 ) + + $ 6*N + N*( M + NP2 ) + + $ MAX( 14*N + 23, 16*N, 2*N + M2 + NP2, 3*( M2 + NP2 ) ) + MINWRK = MAX( IWB, IWC, IWD, IWG ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -31 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10DD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + RCOND( 5 ) = ONE + RCOND( 6 ) = ONE + RCOND( 7 ) = ONE + RCOND( 8 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance in rank determination. +C + TOLL = THOUSN*DLAMCH( 'Epsilon' ) + END IF +C +C Workspace usage. +C + IWS = (N+NP1)*(N+M2) + 1 + IWRK = IWS + (N+M2) +C +C jTheta +C Determine if |A-e I B2 | has full column rank at +C | C1 D12| +C Theta = Pi/2 . +C Workspace: need (N+NP1+1)*(N+M2) + MAX(3*(N+M2)+N+NP1,5*(N+M2)); +C prefer larger. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N+NP1 ) + CALL DLACPY( 'Full', NP1, N, C, LDC, DWORK( N+1 ), N+NP1 ) + CALL DLACPY( 'Full', N, M2, B( 1, M1+1 ), LDB, + $ DWORK( (N+NP1)*N+1 ), N+NP1 ) + CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, + $ DWORK( (N+NP1)*N+N+1 ), N+NP1 ) + CALL DGESVD( 'N', 'N', N+NP1, N+M2, DWORK, N+NP1, DWORK( IWS ), + $ DWORK, N+NP1, DWORK, N+M2, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 9 + RETURN + END IF + IF( DWORK( IWS+N+M2 ) / DWORK( IWS ).LE.TOLL ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C +C Workspace usage. +C + IWS = (N+NP2)*(N+M1) + 1 + IWRK = IWS + (N+NP2) +C +C jTheta +C Determine if |A-e I B1 | has full row rank at +C | C2 D21| +C Theta = Pi/2 . +C Workspace: need (N+NP2)*(N+M1+1) + +C MAX(3*(N+NP2)+N+M1,5*(N+NP2)); +C prefer larger. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N+NP2 ) + CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1), LDC, DWORK( N+1 ), + $ N+NP2 ) + CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( (N+NP2)*N+1 ), + $ N+NP2 ) + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, + $ DWORK( (N+NP2)*N+N+1 ), N+NP2 ) + CALL DGESVD( 'N', 'N', N+NP2, N+M1, DWORK, N+NP2, DWORK( IWS ), + $ DWORK, N+NP2, DWORK, N+M1, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 9 + RETURN + END IF + IF( DWORK( IWS+N+NP2 ) / DWORK( IWS ).LE.TOLL ) THEN + INFO = 2 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWS = NP1*M2 + 1 + IWRK = IWS + M2 +C +C Determine if D12 has full column rank. +C Workspace: need (NP1+1)*M2 + MAX(3*M2+NP1,5*M2); +C prefer larger. +C + CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, DWORK, NP1 ) + CALL DGESVD( 'N', 'N', NP1, M2, DWORK, NP1, DWORK( IWS ), DWORK, + $ NP1, DWORK, M2, DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 9 + RETURN + END IF + IF( DWORK( IWS+M2 ) / DWORK( IWS ).LE.TOLL ) THEN + INFO = 3 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWS = NP2*M1 + 1 + IWRK = IWS + NP2 +C +C Determine if D21 has full row rank. +C Workspace: need NP2*(M1+1) + MAX(3*NP2+M1,5*NP2); +C prefer larger. +C + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, DWORK, NP2 ) + CALL DGESVD( 'N', 'N', NP2, M1, DWORK, NP2, DWORK( IWS ), DWORK, + $ NP2, DWORK, M1, DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 9 + RETURN + END IF + IF( DWORK( IWS+NP2 ) / DWORK( IWS ).LE.TOLL ) THEN + INFO = 4 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWV = 1 + IWB = IWV + M*M + IWC = IWB + N*M1 + IWD = IWC + ( M2 + NP2 )*N + IWQ = IWD + ( M2 + NP2 )*M1 + IWL = IWQ + N*N + IWR = IWL + N*M + IWI = IWR + 2*N + IWH = IWI + 2*N + IWS = IWH + 2*N + IWT = IWS + ( 2*N + M )*( 2*N + M ) + IWU = IWT + ( 2*N + M )*2*N + IWRK = IWU + 4*N*N + IR2 = IWV + M1 + IR3 = IR2 + M*M1 +C +C Compute R0 = |D11'||D11 D12| -|gamma^2*Im1 0| . +C |D12'| | 0 0| +C + CALL DSYRK( 'Lower', 'Transpose', M, NP1, ONE, D, LDD, ZERO, + $ DWORK, M ) + DO 10 J = 1, M*M1, M + 1 + DWORK( J ) = DWORK( J ) - GAMMA*GAMMA + 10 CONTINUE +C +C Compute C1'*C1 . +C + CALL DSYRK( 'Lower', 'Transpose', N, NP1, ONE, C, LDC, ZERO, + $ DWORK( IWQ ), N ) +C +C Compute C1'*|D11 D12| . +C + CALL DGEMM( 'Transpose', 'NoTranspose', N, M, NP1, ONE, C, LDC, + $ D, LDD, ZERO, DWORK( IWL ), N ) +C +C Solution of the X-Riccati equation. +C Workspace: need 13*N*N + 2*M*M + N*(8*M+NP2) + M1*(M2+NP2) + +C 6*N + max(14*N+23,16*N,2*N+M,3*M); +C prefer larger. +C + CALL SB02OD( 'D', 'B', 'N', 'L', 'N', 'S', N, M, NP, A, LDA, B, + $ LDB, DWORK( IWQ ), N, DWORK, M, DWORK( IWL ), N, + $ RCOND2, X, LDX, DWORK( IWR ), DWORK( IWI ), + $ DWORK( IWH ), DWORK( IWS ), 2*N+M, DWORK( IWT ), + $ 2*N+M, DWORK( IWU ), 2*N, TOLL, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Condition estimation. +C Workspace: need 4*N*N + 2*M*M + N*(3*M+NP2) + M1*(M2+NP2) + +C max(5*N,max(3,2*N*N)+N*N); +C prefer larger. +C + IWS = IWR + IWH = IWS + M*M + IWT = IWH + N*M + IWU = IWT + N*N + IWG = IWU + N*N + IWRK = IWG + N*N + CALL DLACPY( 'Lower', M, M, DWORK, M, DWORK( IWS ), M ) + CALL DSYTRF( 'Lower', M, DWORK( IWS ), M, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C + CALL MA02AD( 'Full', N, M, B, LDB, DWORK( IWH ), M ) + CALL DSYTRS( 'Lower', M, N, DWORK( IWS ), M, IWORK, DWORK( IWH ), + $ M, INFO2 ) + CALL MB01RX( 'Left', 'Lower', 'NoTranspose', N, M, ZERO, ONE, + $ DWORK( IWG ), N, B, LDB, DWORK( IWH ), M, INFO2 ) + CALL SB02SD( 'C', 'N', 'N', 'L', 'O', N, A, LDA, DWORK( IWT ), N, + $ DWORK( IWU ), N, DWORK( IWG ), N, DWORK( IWQ ), N, X, + $ LDX, SEPD, RCOND( 7 ), FERR, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) RCOND( 7 ) = ZERO + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWRK = IWR +C +C Compute the lower triangle of |R1 R2'| = R0 + B'*X*B . +C |R2 R3 | +C + CALL MB01RU( 'Lower', 'Transpose', M, N, ONE, ONE, DWORK, M, + $ B, LDB, X, LDX, DWORK( IWRK ), M*N, INFO2 ) +C +C Compute the Cholesky factorization of R3, R3 = V12'*V12 . +C Note that V12' is stored. +C + ANORM = DLANSY( '1', 'Lower', M2, DWORK( IR3 ), M, DWORK( IWRK ) ) + CALL DPOTRF( 'Lower', M2, DWORK( IR3 ), M, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + CALL DPOCON( 'Lower', M2, DWORK( IR3 ), M, ANORM, RCOND( 1 ), + $ DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 1 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C + CALL DTRCON( '1', 'Lower', 'NonUnit', M2, DWORK( IR3 ), M, + $ RCOND( 5 ), DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 5 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C +C Compute R2 <- inv(V12')*R2 . +C + CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M2, M1, + $ ONE, DWORK( IR3 ), M, DWORK( IR2 ), M ) +C +C Compute -Nabla = R2'*inv(R3)*R2 - R1 . +C + CALL DSYRK( 'Lower', 'Transpose', M1, M2, ONE, DWORK( IR2 ), M, + $ -ONE, DWORK, M ) +C +C Compute the Cholesky factorization of -Nabla, -Nabla = V21t'*V21t. +C Note that V21t' is stored. +C + ANORM = DLANSY( '1', 'Lower', M1, DWORK, M, DWORK( IWRK ) ) + CALL DPOTRF( 'Lower', M1, DWORK, M, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + CALL DPOCON( 'Lower', M1, DWORK, M, ANORM, RCOND( 2 ), + $ DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 2 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C + CALL DTRCON( '1', 'Lower', 'NonUnit', M1, DWORK, M, RCOND( 3 ), + $ DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 3 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C +C Compute X*A . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, X, LDX, + $ A, LDA, ZERO, DWORK( IWQ ), N ) +C +C Compute |L1| = |D11'|*C1 + B'*X*A . +C |L2| = |D12'| +C + CALL MA02AD( 'Full', N, M, DWORK( IWL ), N, DWORK( IWRK ), M ) + CALL DLACPY( 'Full', M, N, DWORK( IWRK ), M, DWORK( IWL ), M ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, N, N, ONE, B, LDB, + $ DWORK( IWQ ), N, ONE, DWORK( IWL ), M ) +C +C Compute L2 <- inv(V12')*L2 . +C + CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M2, N, ONE, + $ DWORK( IR3 ), M, DWORK( IWL+M1 ), M ) +C +C Compute L_Nabla = L1 - R2'*inv(R3)*L2 . +C + CALL DGEMM( 'Transpose', 'NoTranspose', M1, N, M2, -ONE, + $ DWORK( IR2 ), M, DWORK( IWL+M1 ), M, ONE, + $ DWORK( IWL ), M ) +C +C Compute L_Nabla <- inv(V21t')*L_Nabla . +C + CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M1, N, ONE, + $ DWORK, M, DWORK( IWL ), M ) +C +C Compute Bt1 = B1*inv(V21t) . +C + CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( IWB ), N ) + CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', N, M1, ONE, + $ DWORK, M, DWORK( IWB ), N ) +C +C Compute At . +C + CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M1, ONE, + $ DWORK( IWB ), N, DWORK( IWL ), M, ONE, AK, LDAK ) +C +C Scale Bt1 . +C + CALL DSCAL( N*M1, GAMMA, DWORK( IWB ), 1 ) +C +C Compute |Dt11| = |R2 |*inv(V21t) . +C |Dt21| |D21| +C + CALL DLACPY( 'Full', M2, M1, DWORK( IR2 ), M, DWORK( IWD ), + $ M2+NP2 ) + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, DWORK( IWD+M2 ), + $ M2+NP2 ) + CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', M2+NP2, + $ M1, ONE, DWORK, M, DWORK( IWD ), M2+NP2 ) +C +C Compute Ct = |Ct1| = |L2| + |Dt11|*inv(V21t')*L_Nabla . +C |Ct2| = |C2| + |Dt21| +C + CALL DLACPY( 'Full', M2, N, DWORK( IWL+M1 ), M, DWORK( IWC ), + $ M2+NP2 ) + CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1 ), LDC, DWORK( IWC+M2 ), + $ M2+NP2 ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M2+NP2, N, M1, ONE, + $ DWORK( IWD ), M2+NP2, DWORK( IWL ), M, ONE, + $ DWORK( IWC ), M2+NP2 ) +C +C Scale |Dt11| . +C |Dt21| +C + CALL DSCAL( ( M2+NP2 )*M1, GAMMA, DWORK( IWD ), 1 ) +C +C Workspace usage. +C + IWW = IWD + ( M2 + NP2 )*M1 + IWQ = IWW + ( M2 + NP2 )*( M2 + NP2 ) + IWL = IWQ + N*N + IWR = IWL + N*( M2 + NP2 ) + IWI = IWR + 2*N + IWH = IWI + 2*N + IWS = IWH + 2*N + IWT = IWS + ( 2*N + M2 + NP2 )*( 2*N + M2 + NP2 ) + IWU = IWT + ( 2*N + M2 + NP2 )*2*N + IWG = IWU + 4*N*N + IWRK = IWG + ( M2 + NP2 )*N + IS2 = IWW + ( M2 + NP2 )*M2 + IS3 = IS2 + M2 +C +C Compute S0 = |Dt11||Dt11' Dt21'| -|gamma^2*Im2 0| . +C |Dt21| | 0 0| +C + CALL DSYRK( 'Upper', 'NoTranspose', M2+NP2, M1, ONE, DWORK( IWD ), + $ M2+NP2, ZERO, DWORK( IWW ), M2+NP2 ) + DO 20 J = IWW, IWW - 1 + ( M2 + NP2 )*M2, M2 + NP2 + 1 + DWORK( J ) = DWORK( J ) - GAMMA*GAMMA + 20 CONTINUE +C +C Compute Bt1*Bt1' . +C + CALL DSYRK( 'Upper', 'NoTranspose', N, M1, ONE, DWORK( IWB ), N, + $ ZERO, DWORK( IWQ ), N ) +C +C Compute Bt1*|Dt11' Dt21'| . +C + CALL DGEMM( 'NoTranspose', 'Transpose', N, M2+NP2, M1, ONE, + $ DWORK( IWB ), N, DWORK( IWD ), M2+NP2, ZERO, + $ DWORK( IWL ), N ) +C +C Transpose At in situ (in AK) . +C + DO 30 J = 2, N + CALL DSWAP( J-1, AK( J, 1 ), LDAK, AK( 1, J ), 1 ) + 30 CONTINUE +C +C Transpose Ct . +C + CALL MA02AD( 'Full', M2+NP2, N, DWORK( IWC ), M2+NP2, + $ DWORK( IWG ), N ) +C +C Solution of the Z-Riccati equation. +C Workspace: need 13*N*N + M*M + (8*N+M+M2+2*NP2)*(M2+NP2) + +C N*(M+NP2) + 6*N + +C max(14*N+23,16*N,2*N+M2+NP2,3*(M2+NP2)); +C prefer larger. +C + CALL SB02OD( 'D', 'B', 'N', 'U', 'N', 'S', N, M2+NP2, NP, AK, + $ LDAK, DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWW ), + $ M2+NP2, DWORK( IWL ), N, RCOND2, Z, LDZ, DWORK( IWR), + $ DWORK( IWI ), DWORK( IWH ), DWORK( IWS ), 2*N+M2+NP2, + $ DWORK( IWT ), 2*N+M2+NP2, DWORK( IWU ), 2*N, TOLL, + $ IWORK, DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 7 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Condition estimation. +C Workspace: need 4*N*N + M*M + 2*(M2+NP2)*(M2+NP2)+ +C N*(M+2*M2+3*NP2) + (M2+NP2)*M1 + +C max(5*N,max(3,2*N*N)+N*N); +C prefer larger. +C + IWS = IWR + IWH = IWS + ( M2 + NP2 )*( M2 + NP2 ) + IWT = IWH + N*( M2 + NP2 ) + IWU = IWT + N*N + IWG = IWU + N*N + IWRK = IWG + N*N + CALL DLACPY( 'Upper', M2+NP2, M2+NP2, DWORK( IWW ), M2+NP2, + $ DWORK( IWS ), M2+NP2 ) + CALL DSYTRF( 'Upper', M2+NP2, DWORK( IWS ), M2+NP2, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C + CALL DLACPY( 'Full', M2+NP2, N, DWORK( IWC ), M2+NP2, + $ DWORK( IWH ), M2+NP2 ) + CALL DSYTRS( 'Upper', M2+NP2, N, DWORK( IWS ), M2+NP2, IWORK, + $ DWORK( IWH ), M2+NP2, INFO2 ) + CALL MB01RX( 'Left', 'Upper', 'Transpose', N, M2+NP2, ZERO, ONE, + $ DWORK( IWG ), N, DWORK( IWC ), M2+NP2, DWORK( IWH ), + $ M2+NP2, INFO2 ) + CALL SB02SD( 'C', 'N', 'N', 'U', 'O', N, AK, LDAK, DWORK( IWT ), + $ N, DWORK( IWU ), N, DWORK( IWG ), N, DWORK( IWQ ), N, + $ Z, LDZ, SEPD, RCOND( 8 ), FERR, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) RCOND( 8 ) = ZERO + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWRK = IWR +C +C Compute the upper triangle of +C |St1 St2| = S0 + |Ct1|*Z*|Ct1' Ct2'| . +C |St2' St3| |Ct2| +C + CALL MB01RU( 'Upper', 'NoTranspose', M2+NP2, N, ONE, ONE, + $ DWORK( IWW ), M2+NP2, DWORK( IWC ), M2+NP2, Z, LDZ, + $ DWORK( IWRK ), (M2+NP2)*N, INFO2 ) +C +C Compute the Cholesky factorization of St3, St3 = U12'*U12 . +C + ANORM = DLANSY( '1', 'Upper', NP2, DWORK( IS3 ), M2+NP2, + $ DWORK( IWRK ) ) + CALL DPOTRF( 'Upper', NP2, DWORK( IS3 ), M2+NP2, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + CALL DPOCON( 'Upper', NP2, DWORK( IS3 ), M2+NP2, ANORM, + $ RCOND( 4 ), DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 4 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C +C Compute St2 <- St2*inv(U12) . +C + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', M2, NP2, + $ ONE, DWORK( IS3 ), M2+NP2, DWORK( IS2 ), M2+NP2 ) +C +C Check the negative definiteness of St1 - St2*inv(St3)*St2' . +C + CALL DSYRK( 'Upper', 'NoTranspose', M2, NP2, ONE, DWORK( IS2 ), + $ M2+NP2, -ONE, DWORK( IWW ), M2+NP2 ) + CALL DPOTRF( 'Upper', M2, DWORK( IWW ), M2+NP2, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF +C +C Restore At in situ . +C + DO 40 J = 2, N + CALL DSWAP( J-1, AK( J, 1 ), LDAK, AK( 1, J ), 1 ) + 40 CONTINUE +C +C Compute At*Z . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, AK, LDAK, + $ Z, LDZ, ZERO, DWORK( IWRK ), N ) +C +C Compute Mt2 = Bt1*Dt21' + At*Z*Ct2' in BK . +C + CALL DLACPY( 'Full', N, NP2, DWORK( IWL+N*M2 ), N, BK, LDBK ) + CALL DGEMM( 'NoTranspose', 'Transpose', N, NP2, N, ONE, + $ DWORK( IWRK ), N, DWORK( IWC+M2 ), M2+NP2, ONE, + $ BK, LDBK ) +C +C Compute St2 <- St2*inv(U12') . +C + CALL DTRSM( 'Right', 'Upper', 'Transpose', 'NonUnit', M2, NP2, + $ ONE, DWORK( IS3 ), M2+NP2, DWORK( IS2 ), M2+NP2 ) +C +C Compute DKHAT = -inv(V12)*St2 in DK . +C + CALL DLACPY( 'Full', M2, NP2, DWORK( IS2 ), M2+NP2, DK, LDDK ) + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', M2, NP2, + $ -ONE, DWORK( IR3 ), M, DK, LDDK ) +C +C Compute CKHAT = -inv(V12)*(Ct1 - St2*inv(St3)*Ct2) in CK . +C + CALL DLACPY( 'Full', M2, N, DWORK( IWC ), M2+NP2, CK, LDCK ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M2, N, NP2, -ONE, + $ DWORK( IS2 ), M2+NP2, DWORK( IWC+M2 ), M2+NP2, ONE, + $ CK, LDCK ) + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', M2, N, -ONE, + $ DWORK( IR3 ), M, CK, LDCK ) +C +C Compute Mt2*inv(St3) in BK . +C + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, NP2, + $ ONE, DWORK( IS3 ), M2+NP2, BK, LDBK ) + CALL DTRSM( 'Right', 'Upper', 'Transpose', 'NonUnit', N, NP2, + $ ONE, DWORK( IS3 ), M2+NP2, BK, LDBK ) +C +C Compute AKHAT in AK . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M2, ONE, + $ B( 1, M1+1 ), LDB, CK, LDCK, ONE, AK, LDAK ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, NP2, -ONE, BK, + $ LDBK, DWORK( IWC+M2 ), M2+NP2, ONE, AK, LDAK ) +C +C Compute BKHAT in BK . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, NP2, M2, ONE, + $ B( 1, M1+1 ), LDB, DK, LDDK, ONE, BK, LDBK ) +C +C Compute Im2 + DKHAT*D22 . +C + IWRK = M2*M2 + 1 + CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK, M2 ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M2, M2, NP2, ONE, DK, + $ LDDK, D( NP1+1, M1+1 ), LDD, ONE, DWORK, M2 ) + ANORM = DLANGE( '1', M2, M2, DWORK, M2, DWORK( IWRK ) ) + CALL DGETRF( M2, M2, DWORK, M2, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 8 + RETURN + END IF + CALL DGECON( '1', M2, DWORK, M2, ANORM, RCOND( 6 ), DWORK( IWRK ), + $ IWORK( M2+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 6 ).LT.TOLL ) THEN + INFO = 8 + RETURN + END IF +C +C Compute CK . +C + CALL DGETRS( 'NoTranspose', M2, N, DWORK, M2, IWORK, CK, LDCK, + $ INFO2 ) +C +C Compute DK . +C + CALL DGETRS( 'NoTranspose', M2, NP2, DWORK, M2, IWORK, DK, LDDK, + $ INFO2 ) +C +C Compute AK . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M2, NP2, ONE, BK, + $ LDBK, D( NP1+1, M1+1 ), LDD, ZERO, DWORK, N ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M2, -ONE, DWORK, + $ N, CK, LDCK, ONE, AK, LDAK ) +C +C Compute BK . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, NP2, M2, -ONE, DWORK, + $ N, DK, LDDK, ONE, BK, LDBK ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10DD *** + END Added: trunk/octave-forge/extra/control-oo/src/SB10FD.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/SB10FD.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/SB10FD.f 2009-12-04 19:53:15 UTC (rev 6595) @@ -0,0 +1,469 @@ + SUBROUTINE SB10FD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, + $ C, LDC, D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, + $ DK, LDDK, RCOND, TOL, IWORK, DWORK, LDWORK, + $ BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To compute the matrices of an H-infinity (sub)optimal n-state +C controller +C +C | AK | BK | +C K = |----|----|, +C | CK | DK | +C +C using modified Glover's and Doyle's 1988 formulas, for the system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 D22 | +C +C and for a given value of gamma, where B2 has as column size the +C number of control inputs (NCON) and C2 has as row size the number +C of measurements (NMEAS) being provided to the controller. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank and D21 is full row rank, +C +C (A3) | A-j*omega*I B2 | has full column rank for all omega, +C | C1 D12 | +C +C (A4) | A-j*omega*I B1 | has full row rank for all omega. +C | C2 D21 | +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C GAMMA (input) DOUBLE PRECISION +C The value of gamma. It is assumed that gamma is +C sufficiently large so that the controller is admissible. +C GAMMA >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C RCOND (output) DOUBLE PRECISION array, dimension (4) +C RCOND(1) contains the reciprocal condition number of the +C control transformation matrix; +C RCOND(2) contains the reciprocal condition number of the +C measurement transformation matrix; +C RCOND(3) contains an estimate of the reciprocal condition +C number of the X-Riccati equation; +C RCOND(4) contains an estimate of the reciprocal condition +C number of the Y-Riccati equation. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used for controlling the accuracy of the applied +C transformations for computing the normalized form in +C SLICOT Library routine SB10PD. Transformation matrices +C whose reciprocal condition numbers are less than TOL are +C not allowed. If TOL <= 0, then a default value equal to +C sqrt(EPS) is used, where EPS is the relative machine +C precision. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), where +C LIWORK = max(2*max(N,M-NCON,NP-NMEAS,NCON),N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 + +C max(1,LW1,LW2,LW3,LW4,LW5,LW6), where +C LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2)), +C LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2)), +C LW3 = M2 + NP1*NP1 + max(NP1*max(N,M1),3*M2+NP1,5*M2), +C LW4 = NP2 + M1*M1 + max(max(N,NP1)*M1,3*NP2+M1,5*NP2), +C LW5 = 2*N*N + N*(M+NP) + +C max(1,M*M + max(2*M1,3*N*N+max(N*M,10*N*N+12*N+5)), +C NP*NP + max(2*NP1,3*N*N + +C max(N*NP,10*N*N+12*N+5))), +C LW6 = 2*N*N + N*(M+NP) + +C max(1, M2*NP2 + NP2*NP2 + M2*M2 + +C max(D1*D1 + max(2*D1, (D1+D2)*NP2), +C D2*D2 + max(2*D2, D2*M2), 3*N, +C N*(2*NP2 + M2) + +C max(2*N*M2, M2*NP2 + +C max(M2*M2+3*M2, NP2*(2*NP2+ +C M2+max(NP2,N)))))), +C with D1 = NP1 - M2, D2 = M1 - NP2, +C NP1 = NP - NP2, M1 = M - M2. +C For good performance, LDWORK must generally be larger. +C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is +C 2*Q*(3*Q+2*N)+max(1,(N+Q)*(N+Q+6),Q*(Q+max(N,Q,5)+1), +C 2*N*(N+2*Q)+max(1,4*Q*Q+ +C max(2*Q,3*N*N+max(2*N*Q,10*N*N+12*N+5)), +C Q*(3*N+3*Q+max(2*N,4*Q+max(N,Q))))). +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix | A-j*omega*I B2 | had not full +C | C1 D12 | +C column rank in respect to the tolerance EPS; +C = 2: if the matrix | A-j*omega*I B1 | had not full row +C | C2 D21 | +C rank in respect to the tolerance EPS; +C = 3: if the matrix D12 had not full column rank in +C respect to the tolerance TOL; +C = 4: if the matrix D21 had not full row rank in respect +C to the tolerance TOL; +C = 5: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of one of +C the matrices |A B2 |, |A B1 |, D12 or D21). +C |C1 D12| |C2 D21| +C = 6: if the controller is not admissible (too small value +C of gamma); +C = 7: if the X-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 8: if the Y-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 9: if the determinant of Im2 + Tu*D11HAT*Ty*D22 is +C zero [3]. +C +C METHOD +C +C The routine implements the Glover's and Doyle's 1988 formulas [1], +C [2] modified to improve the efficiency as described in [3]. +C +C REFERENCES +C +C [1] Glover, K. and Doyle, J.C. +C State-space formulae for all stabilizing controllers that +C satisfy an Hinf norm bound and relations to risk sensitivity. +C Systems and Control Letters, vol. 11, pp. 167-172, 1988. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of continuous-time +C linear control systems. +C Rep. 98-14, Department of Engineering, Leicester University, +C Leicester, U.K., 1998. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C input and output transformations and on the condition numbers of +C the two Riccati equations, as given by the values of RCOND(1), +C RCOND(2), RCOND(3) and RCOND(4), respectively. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Sept. 1999, Feb. 2000. +C +C KEYWORDS +C +C Algebraic Riccati equation, H-infinity optimal control, robust +C control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDWORK, M, N, NCON, NMEAS, NP + DOUBLE PRECISION GAMMA, TOL +C .. +C .. Array Arguments .. + LOGICAL BWORK( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ RCOND( 4 ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IWC, IWD, IWF, IWH, IWRK, IWTU, IWTY, + $ IWX, IWY, LW1, LW2, LW3, LW4, LW5, LW6, + $ LWAMAX, M1, M2, MINWRK, ND1, ND2, NP1, NP2 + DOUBLE PRECISION TOLL +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DLACPY, SB10PD, SB10QD, SB10RD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( GAMMA.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -14 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -20 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -22 + ELSE +C +C Compute workspace. +C + ND1 = NP1 - M2 + ND2 = M1 - NP2 + LW1 = ( N + NP1 + 1 )*( N + M2 ) + MAX( 3*( N + M2 ) + N + NP1, + $ 5*( N + M2 ) ) + LW2 = ( N + NP2 )*( N + M1 + 1 ) + MAX( 3*( N + NP2 ) + N + + $ M1, 5*( N + NP2 ) ) + LW3 = M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, 5*M2 ) + LW4 = NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, 5*NP2 ) + LW5 = 2*N*N + N*( M + NP ) + + $ MAX( 1, M*M + MAX( 2*M1, 3*N*N + + $ MAX( N*M, 10*N*N + 12*N + 5 ) ), + $ NP*NP + MAX( 2*NP1, 3*N*N + + $ MAX( N*NP, 10*N*N + 12*N + 5 ) ) ) + LW6 = 2*N*N + N*( M + NP ) + + $ MAX( 1, M2*NP2 + NP2*NP2 + M2*M2 + + $ MAX( ND1*ND1 + MAX( 2*ND1, ( ND1 + ND2 )*NP2 ), + $ ND2*ND2 + MAX( 2*ND2, ND2*M2 ), 3*N, + $ N*( 2*NP2 + M2 ) + + $ MAX( 2*N*M2, M2*NP2 + + $ MAX( M2*M2 + 3*M2, NP2*( 2*NP2 + + $ M2 + MAX( NP2, N ) ) ) ) ) ) + MINWRK = N*M + NP*( N + M ) + M2*M2 + NP2*NP2 + + $ MAX( 1, LW1, LW2, LW3, LW4, LW5, LW6 ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -27 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10FD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance. +C + TOLL = SQRT( DLAMCH( 'Epsilon' ) ) + END IF +C +C Workspace usage. +C + IWC = 1 + N*M + IWD = IWC + NP*N + IWTU = IWD + NP*M + IWTY = IWTU + M2*M2 + IWRK = IWTY + NP2*NP2 +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NP ) + CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NP ) +C +C Transform the system so that D12 and D21 satisfy the formulas +C in the computation of the Hinf (sub)optimal controller. +C + CALL SB10PD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWTU ), + $ M2, DWORK( IWTY ), NP2, RCOND, TOLL, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = INFO2 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C + IWX = IWRK + IWY = IWX + N*N + IWF = IWY + N*N + IWH = IWF + M*N + IWRK = IWH + N*NP +C +C Compute the (sub)optimal state feedback and output injection +C matrices. +C + CALL SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), + $ M, DWORK( IWH ), N, DWORK( IWX ), N, DWORK( IWY ), + $ N, RCOND(3), IWORK, DWORK( IWRK ), LDWORK-IWRK+1, + $ BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = INFO2 + 5 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute the Hinf (sub)optimal controller. +C + CALL SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), + $ M, DWORK( IWH ), N, DWORK( IWTU ), M2, DWORK( IWTY ), + $ NP2, DWORK( IWX ), N, DWORK( IWY ), N, AK, LDAK, BK, + $ LDBK, CK, LDCK, DK, LDDK, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.EQ.1 ) THEN + INFO = 6 + RETURN + ELSE IF( INFO2.EQ.2 ) THEN + INFO = 9 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10FD *** + END Added: trunk/octave-forge/extra/control-oo/src/SB10QD.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/SB10QD.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/SB10QD.f 2009-12-04 19:53:15 UTC (rev 6595) @@ -0,0 +1,602 @@ + SUBROUTINE SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, + $ C, LDC, D, LDD, F, LDF, H, LDH, X, LDX, Y, LDY, + $ XYCOND, IWORK, DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To compute the state feedback and the output injection +C matrices for an H-infinity (sub)optimal n-state controller, +C using Glover's and Doyle's 1988 formulas, for the system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 D22 | +C +C and for a given value of gamma, where B2 has as column size the +C number of control inputs (NCON) and C2 has as row size the number +C of measurements (NMEAS) being provided to the controller. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank with D12 = | 0 | and D21 is +C | I | +C full row rank wi... [truncated message content] |
From: <par...@us...> - 2009-12-07 16:59:02
|
Revision: 6608 http://octave.svn.sourceforge.net/octave/?rev=6608&view=rev Author: paramaniac Date: 2009-12-07 16:58:45 +0000 (Mon, 07 Dec 2009) Log Message: ----------- control-oo: add augw Modified Paths: -------------- trunk/octave-forge/extra/control-oo/INDEX Added Paths: ----------- trunk/octave-forge/extra/control-oo/inst/augw.m Modified: trunk/octave-forge/extra/control-oo/INDEX =================================================================== --- trunk/octave-forge/extra/control-oo/INDEX 2009-12-07 15:09:28 UTC (rev 6607) +++ trunk/octave-forge/extra/control-oo/INDEX 2009-12-07 16:58:45 UTC (rev 6608) @@ -53,6 +53,7 @@ kalman lqr Controller Synthesis + augw h2syn hinfsyn State-Space Models Added: trunk/octave-forge/extra/control-oo/inst/augw.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/augw.m (rev 0) +++ trunk/octave-forge/extra/control-oo/inst/augw.m 2009-12-07 16:58:45 UTC (rev 6608) @@ -0,0 +1,122 @@ +## Copyright (C) 2009 Lukas F. Reichlin +## +## This file is part of LTI Syncope. +## +## LTI Syncope 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. +## +## LTI Syncope 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, see <http://www.gnu.org/licenses/>. + +## -*- texinfo -*- +## @deftypefn{Function File} {@var{P} =} hinfsyn (@var{G}, @var{W1}, @var{W2}, @var{W3}) +## Extend plant for stacked S/T/KS problem. +## @example +## @group +## +## | W1 | -W1*G | z1 = W1 r - W1 G u +## | 0 | W2 | z2 = W2 u +## P = | 0 | W3*G | z3 = W3 G u +## |----+-------| +## | I | -G | e = r - G u +## +------+ z1 +## +---------------------------------------->| W1 |-----> +## | +------+ +## | +------+ z2 +## | +---------------------->| W2 |-----> +## | | +------+ +## r + e | +--------+ u | +--------+ y +------+ z3 +## ----->(+)---+-->| K(s) |----+-->| G(s) |----+---->| W3 |-----> +## ^ - +--------+ +--------+ | +------+ +## | | +## +----------------------------------------+ +## +## +--------+ +## | |-----> z1 (p1x1) +## r (px1) ----->| P(s) |-----> z2 (p2x1) +## | |-----> z3 (p3x1) +## u (mx1) ----->| |-----> e (px1) +## +--------+ +## +## +--------+ +## r ----->| |-----> z +## | P(s) | +## u +---->| |-----+ e +## | +--------+ | +## | | +## | +--------+ | +## +-----| K(s) |<----+ +## +--------+ +## +## Reference: +## Skogestad, S. and Postlethwaite I. +## Multivariable Feedback Control: Analysis and Design +## Second Edition +## Wiley 2005 +## Chapter 3.8: General Control Problem Formulation +## @end group +## @end example +## @end deftypefn + +## Author: Lukas Reichlin <luk...@gm...> +## Created: December 2009 +## Version: 0.1 + +function P = augw (G, W1 = [], W2 = [], W3 = []) + + if (nargin == 0 || nargin > 4) + print_usage (); + endif + + G = ss (G); + W1 = ss (W1); + W2 = ss (W2); + W3 = ss (W3); + + [p, m] = size (G); + [p1, m1] = size (W1) + [p2, m2] = size (W2); + [p3, m3] = size (W3); + + if (m1 != 0 && m1 != p) + error ("augw: W1 must have %d inputs", p); + endif + + if (m2 != 0 && m2 != m) + error ("augw: W2 must have %d inputs", m); + endif + + if (m3 != 0 && m3 != p) + error ("augw: W3 must have %d inputs", p); + endif + + ## Pr = [1; 0; 0; 1]; + ## Pu = [-1; 0; 1; -1]*G + [0; 1; 0; 0]; + + Pr = ss ([eye(m1,p) ; + zeros(m2,p); + zeros(m3,p); + eye(p,p) ]); + + Pu1 = ss ([-eye(m1,p) ; + zeros(m2,p); + eye(m3,p) ; + -eye(p,p) ]); + + Pu2 = ss ([zeros(m1,m); + eye(m2,m) ; + zeros(m3,m); + zeros(p,m) ]); + + Pu = Pu1 * G + Pu2; + + P = append (W1, W2, W3, eye (p, p)) * [Pr, Pu]; + +endfunction \ No newline at end of file This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <par...@us...> - 2009-12-07 19:07:42
|
Revision: 6611 http://octave.svn.sourceforge.net/octave/?rev=6611&view=rev Author: paramaniac Date: 2009-12-07 19:07:31 +0000 (Mon, 07 Dec 2009) Log Message: ----------- control-oo: add mixsyn draft code, unify variable name Modified Paths: -------------- trunk/octave-forge/extra/control-oo/INDEX trunk/octave-forge/extra/control-oo/inst/h2syn.m trunk/octave-forge/extra/control-oo/inst/hinfsyn.m Added Paths: ----------- trunk/octave-forge/extra/control-oo/inst/mixsyn.m Modified: trunk/octave-forge/extra/control-oo/INDEX =================================================================== --- trunk/octave-forge/extra/control-oo/INDEX 2009-12-07 18:34:50 UTC (rev 6610) +++ trunk/octave-forge/extra/control-oo/INDEX 2009-12-07 19:07:31 UTC (rev 6611) @@ -56,6 +56,7 @@ augw h2syn hinfsyn + mixsyn State-Space Models ctrb gram Modified: trunk/octave-forge/extra/control-oo/inst/h2syn.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/h2syn.m 2009-12-07 18:34:50 UTC (rev 6610) +++ trunk/octave-forge/extra/control-oo/inst/h2syn.m 2009-12-07 19:07:31 UTC (rev 6611) @@ -16,7 +16,7 @@ ## along with this program. If not, see <http://www.gnu.org/licenses/>. ## -*- texinfo -*- -## @deftypefn{Function File} {[@var{K}, @var{T}, @var{gamma}] =} h2syn (@var{P}, @var{nmeas}, @var{ncon}) +## @deftypefn{Function File} {[@var{K}, @var{N}, @var{gamma}] =} h2syn (@var{P}, @var{nmeas}, @var{ncon}) ## H2 control synthesis for LTI plant. ## Uses SLICOT SB10HD and SB10ED by courtesy of NICONET e.V. ## <http://www.slicot.org> @@ -79,10 +79,10 @@ K = ss (ak, bk, ck, dk, tsam); if (nargout > 1) - T = lft (P, K); - varargout{1} = T; + N = lft (P, K); + varargout{1} = N; if (nargout > 2) - varargout{2} = norm (T); + varargout{2} = norm (N); endif endif Modified: trunk/octave-forge/extra/control-oo/inst/hinfsyn.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/hinfsyn.m 2009-12-07 18:34:50 UTC (rev 6610) +++ trunk/octave-forge/extra/control-oo/inst/hinfsyn.m 2009-12-07 19:07:31 UTC (rev 6611) @@ -16,8 +16,8 @@ ## along with this program. If not, see <http://www.gnu.org/licenses/>. ## -*- texinfo -*- -## @deftypefn{Function File} {[@var{K}, @var{T}, @var{gamma}] =} hinfsyn (@var{P}, @var{nmeas}, @var{ncon}) -## @deftypefnx{Function File} {[@var{K}, @var{T}, @var{gamma}] =} hinfsyn (@var{P}, @var{nmeas}, @var{ncon}, @var{gamma}) +## @deftypefn{Function File} {[@var{K}, @var{N}, @var{gamma}] =} hinfsyn (@var{P}, @var{nmeas}, @var{ncon}) +## @deftypefnx{Function File} {[@var{K}, @var{N}, @var{gamma}] =} hinfsyn (@var{P}, @var{nmeas}, @var{ncon}, @var{gamma}) ## H-infinity control synthesis for LTI plant. ## Uses SLICOT SB10FD and SB10DD by courtesy of NICONET e.V. ## <http://www.slicot.org> @@ -78,10 +78,10 @@ K = ss (ak, bk, ck, dk, tsam); if (nargout > 1) - T = lft (P, K); - varargout{1} = T; + N = lft (P, K); + varargout{1} = N; if (nargout > 2) - varargout{2} = norm (T); + varargout{2} = norm (N); endif endif Added: trunk/octave-forge/extra/control-oo/inst/mixsyn.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/mixsyn.m (rev 0) +++ trunk/octave-forge/extra/control-oo/inst/mixsyn.m 2009-12-07 19:07:31 UTC (rev 6611) @@ -0,0 +1,40 @@ +## Copyright (C) 2009 Lukas F. Reichlin +## +## This file is part of LTI Syncope. +## +## LTI Syncope 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. +## +## LTI Syncope 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, see <http://www.gnu.org/licenses/>. + +## -*- texinfo -*- +## @deftypefn{Function File} {[@var{K}, @var{N}, @var{gamma}] =} mixsyn (@var{G}, @var{W1}, @var{W2}, @var{W3}) +## Solve stacked S/T/KS problem. +## TODO: doc +## @end deftypefn + +## Author: Lukas Reichlin <luk...@gm...> +## Created: December 2009 +## Version: 0.1 + +function [K, N, gamma] = mixsyn (G, W1 = [], W2 = [], W3 = [], gmax = 1e6) + + if (nargin == 0 || nargin > 5) + print_usage (); + endif + + [p, m] = size (G); + + P = augw (G, W1, W2, W3); + + [K, N, gamma] = hinfsyn (P, p, m, gmax); + +endfunction \ No newline at end of file This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <par...@us...> - 2009-12-13 09:00:21
|
Revision: 6640 http://octave.svn.sourceforge.net/octave/?rev=6640&view=rev Author: paramaniac Date: 2009-12-13 09:00:13 +0000 (Sun, 13 Dec 2009) Log Message: ----------- control-oo: beef up place.m by adding parameter alpha Modified Paths: -------------- trunk/octave-forge/extra/control-oo/inst/place.m trunk/octave-forge/extra/control-oo/src/slsb01bd.cc Modified: trunk/octave-forge/extra/control-oo/inst/place.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/place.m 2009-12-12 14:04:48 UTC (rev 6639) +++ trunk/octave-forge/extra/control-oo/inst/place.m 2009-12-13 09:00:13 UTC (rev 6640) @@ -18,29 +18,74 @@ ## -*- texinfo -*- ## @deftypefn {Function File} {@var{f} =} place (@var{sys}, @var{p}) ## @deftypefnx {Function File} {@var{f} =} place (@var{a}, @var{b}, @var{p}) +## @deftypefnx {Function File} {[@var{f}, @var{nfp}, @var{nap}, @var{nup}] =} place (@var{sys}, @var{p}, @var{alpha}) +## @deftypefnx {Function File} {[@var{f}, @var{nfp}, @var{nap}, @var{nup}] =} place (@var{a}, @var{b}, @var{p}, @var{alpha}) ## Pole assignment for a given matrix pair (A,B) such that eig (A-B*F) = P. +## If parameter alpha is specified, poles with real parts (continuous time) +## or moduli (discrete time) below alpha are left untouched. ## Uses SLICOT SB01BD by courtesy of NICONET e.V. -## Special thanks to Peter Benner from TU Chemnitz for his advice. +## <http://www.slicot.org> +## +## @strong{Inputs} +## @table @var +## @item sys +## LTI system. +## @item p +## Desired eigenvalues of the closed-loop system state-matrix A-B*F. +## @item alpha +## Specifies the maximum admissible value, either for real +## parts or for moduli, of the eigenvalues of A which will +## not be modified by the eigenvalue assignment algorithm. +## ALPHA >= 0 for discrete-time systems. +## @end table +## +## @strong{Outputs} +## @table @var +## @item f +## State feedback gain matrix. +## @item nfp +## The number of fixed poles, i.e. eigenvalues of A having +## real parts less than ALPHA, or moduli less than ALPHA. +## These eigenvalues are not modified by place. +## @item nap +## The number of assigned eigenvalues. NAP = N-NFP-NUP. +## @item nup +## The number of uncontrollable eigenvalues detected by the +## eigenvalue assignment algorithm. +## @end table +## ## @end deftypefn +## Special thanks to Peter Benner from TU Chemnitz for his advice. ## Author: Lukas Reichlin <luk...@gm...> ## Created: December 2009 -## Version: 0.1 +## Version: 0.2 -function f = place (a, b, p) +function [f, nfp, nap, nup] = place (a, b, p = [], alpha = []) - ## TODO: add possibility to specify alpha as a fourth parameter + if (nargin < 2 || nargin > 4) + print_usage (); + endif - if (nargin == 2) # place (sys, p) - p = b; - [a, b, c, d, tsam] = ssdata (a); - elseif (nargin == 3) # place (a, b, p) - if (! isnumeric (a) || ! isnumeric (b) || ! issquare (a) || rows (a) != rows (b)) - error ("place: matrices a and b not conformal"); + if (isa (a, "lti")) # place (sys, p), place (sys, p, alpha) + if (nargin > 3) # nargin < 2 already tested + print_usage (); + else + alpha = p; + p = b; + sys = a; + [a, b] = ssdata (sys); + digital = ! isct (sys); # treat tsam = -1 as continuous system endif - tsam = 0; # assume continuous system - else - print_usage (); + else # place (a, b, p), place (a, b, p, alpha) + if (nargin < 3) # nargin > 4 already tested + print_usage (); + else + if (! isnumeric (a) || ! isnumeric (b) || ! issquare (a) || rows (a) != rows (b)) + error ("place: matrices a and b not conformal"); + endif + digital = 0; # assume continuous system + endif endif if (! isnumeric (p) || ! isvector (p) || isempty (p)) @@ -58,14 +103,16 @@ error ("place: at most %d eigenvalues can be assigned for the given matrix a (%dx%d)", n, n, n); endif - - if (tsam > 0) - alpha = 0; - else - alpha = - norm (a, inf); + + if (isempty (alpha)) + if (digital) + alpha = 0; + else + alpha = - norm (a, inf); + endif endif - [f, iwarn] = slsb01bd (a, b, wr, wi, tsam, alpha); + [f, iwarn, nfp, nap, nup] = slsb01bd (a, b, wr, wi, digital, alpha); f = -f; # A + B*F --> A - B*F if (iwarn) @@ -83,4 +130,30 @@ %! P = [-1, -0.5]; %! Kexpected = [3.5, 3.5]; %!assert (place (ss (A, B, C), P), Kexpected, 2*eps); -%!assert (place (A, B, P), Kexpected, 2*eps); \ No newline at end of file +%!assert (place (A, B, P), Kexpected, 2*eps); + +## FIXME: Test from SLICOT example SB01BD fails +#%!shared F, F_exp +#%! A = [-6.8000 0.0000 -207.0000 0.0000 +#%! 1.0000 0.0000 0.0000 0.0000 +#%! 43.2000 0.0000 0.0000 -4.2000 +#%! 0.0000 0.0000 1.0000 0.0000]; +#%! +#%! B = [ 5.6400 0.0000 +#%! 0.0000 0.0000 +#%! 0.0000 1.1800 +#%! 0.0000 0.0000]; +#%! +#%! P = [(-0.5000 + 0.1500*i) +#%! (-0.5000 +-0.1500*i) +#%! (-2.0000 + 0.0000*i) +#%! (-0.4000 + 0.0000*i)]; +#%! +#%! ALPHA = -0.4; +#%! +#%! F = place (A, B, P, ALPHA) +#%! +#%! F_exp = - [-0.0876 -4.2138 0.0837 -18.1412 +#%! -0.0233 18.2483 -0.4259 -4.8120]; +#%! +#%!assert (F, F_exp, 1e-4); \ No newline at end of file Modified: trunk/octave-forge/extra/control-oo/src/slsb01bd.cc =================================================================== --- trunk/octave-forge/extra/control-oo/src/slsb01bd.cc 2009-12-12 14:04:48 UTC (rev 6639) +++ trunk/octave-forge/extra/control-oo/src/slsb01bd.cc 2009-12-13 09:00:13 UTC (rev 6640) @@ -84,10 +84,10 @@ NDArray b = args(1).array_value (); NDArray wr = args(2).array_value (); NDArray wi = args(3).array_value (); - double tsam = args(4).double_value (); + int digital = args(4).int_value (); double alpha = args(5).double_value (); - if (tsam > 0) + if (digital == 1) dico = 'D'; else dico = 'C'; @@ -150,6 +150,9 @@ // return values retval(0) = f; retval(1) = octave_value (iwarn); + retval(2) = octave_value (nfp); + retval(3) = octave_value (nap); + retval(4) = octave_value (nup); // free memory delete[] dwork; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <par...@us...> - 2009-12-26 10:38:19
|
Revision: 6673 http://octave.svn.sourceforge.net/octave/?rev=6673&view=rev Author: paramaniac Date: 2009-12-26 10:38:11 +0000 (Sat, 26 Dec 2009) Log Message: ----------- control-oo: add rlocus from control-legacy Modified Paths: -------------- trunk/octave-forge/extra/control-oo/INDEX Added Paths: ----------- trunk/octave-forge/extra/control-oo/inst/rlocus.m Modified: trunk/octave-forge/extra/control-oo/INDEX =================================================================== --- trunk/octave-forge/extra/control-oo/INDEX 2009-12-25 07:51:00 UTC (rev 6672) +++ trunk/octave-forge/extra/control-oo/INDEX 2009-12-26 10:38:11 UTC (rev 6673) @@ -48,6 +48,7 @@ Compensator Design estim place + rlocus LQR/LQG Design dlqr kalman Added: trunk/octave-forge/extra/control-oo/inst/rlocus.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/rlocus.m (rev 0) +++ trunk/octave-forge/extra/control-oo/inst/rlocus.m 2009-12-26 10:38:11 UTC (rev 6673) @@ -0,0 +1,346 @@ +## Copyright (C) 1996, 2000, 2004, 2005, 2006, 2007 +## Auburn University. All rights reserved. +## +## +## 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; see the file COPYING. If not, see +## <http://www.gnu.org/licenses/>. + +## -*- texinfo -*- +## @deftypefn {Function File} {[@var{rldata}, @var{k}] =} rlocus (@var{sys}[, @var{increment}, @var{min_k}, @var{max_k}]) +## +## Display root locus plot of the specified @acronym{SISO} system. +## @example +## @group +## ----- --- -------- +## --->| + |---|k|---->| SISO |-----------> +## ----- --- -------- | +## - ^ | +## |_____________________________| +## @end group +## @end example +## +## @strong{Inputs} +## @table @var +## @item sys +## system data structure +## @item min_k +## Minimum value of @var{k} +## @item max_k +## Maximum value of @var{k} +## @item increment +## The increment used in computing gain values +## @end table +## +## @strong{Outputs} +## +## Plots the root locus to the screen. +## @table @var +## @item rldata +## Data points plotted: in column 1 real values, in column 2 the imaginary values. +## @item k +## Gains for real axis break points. +## @end table +## @end deftypefn + +## Author: David Clem +## Author: R. Bruce Tenison <bte...@en...> +## Updated by Kristi McGowan July 1996 for intelligent gain selection +## Updated by John Ingram July 1996 for systems + +## TODO: Improve compatibility + +function [rldata_r, k_break, rlpol, gvec, real_ax_pts] = rlocus (sys, increment, min_k, max_k) + + if (nargin < 1 || nargin > 4) + print_usage (); + endif + + ## Convert the input to a transfer function if necessary + [num, den] = tfdata (sys); # extract numerator/denom polyomials + num = num{:}; + den = den{:}; + lnum = length (num); + lden = length (den); + ## equalize length of num, den polynomials + if (lden < 2) + error ("system has no poles"); + elseif (lnum < lden) + num = [zeros(1,lden-lnum), num]; # so that derivative is shortened by one + endif + + olpol = roots (den); + olzer = roots (num); + nas = lden - lnum; # number of asymptotes + maxk = 0; + if (nas > 0) + cas = (sum (olpol) - sum (olzer)) / nas; + angles = (2*[1:nas]-1)*pi/nas; + # printf("rlocus: there are %d asymptotes centered at %f\n", nas, cas); + else + cas = angles = []; + maxk = 100*den(1)/num(1); + endif + + + # compute real axis break points and corresponding gains + dnum = polyderiv (num); + dden = polyderiv (den); + brkp = conv (den, dnum) - conv (num, dden); + real_ax_pts = roots (brkp); + real_ax_pts = real_ax_pts(find (imag (real_ax_pts) == 0)); + k_break = -polyval (den, real_ax_pts) ./ polyval (num, real_ax_pts); + idx = find (k_break >= 0); + k_break = k_break(idx); + real_ax_pts = real_ax_pts(idx); + if (! isempty (k_break)) + maxk = max (max (k_break), maxk); + endif + + if (nas == 0) + maxk = max (1, 2*maxk); # get at least some root locus + else + ## get distance from breakpoints, poles, and zeros to center of asymptotes + dmax = 3*max (abs ([vec(olzer); vec(olpol); vec(real_ax_pts)] - cas)); + if (dmax == 0) + dmax = 1; + endif + + # get gain for dmax along each asymptote, adjust maxk if necessary + svals = cas + dmax * exp (j*angles); + kvals = -polyval (den, svals) ./ polyval (num, svals); + maxk = max (maxk, max (real (kvals))); + endif + + ## check for input arguments: + if (nargin > 2) + mink = min_k; + else + mink = 0; + endif + if (nargin > 3) + maxk = max_k; + endif + if (nargin > 1) + if (increment <= 0) + error ("increment must be positive"); + else + ngain = (maxk-mink)/increment; + endif + else + ngain = 30; + endif + + ## vector of gains + ngain = max (30, ngain); + gvec = linspace (mink, maxk, ngain); + if (length (k_break)) + gvec = sort ([gvec, vec(k_break)']); + endif + + ## Find the open loop zeros and the initial poles + rlzer = roots (num); + + ## update num to be the same length as den + lnum = length (num); + if (lnum < lden) + num = [zeros(1,lden - lnum),num]; + endif + + ## compute preliminary pole sets + nroots = lden - 1; + for ii = 1:ngain + gain = gvec(ii); + rlpol(1:nroots,ii) = vec(sort (roots (den + gain*num))); + endfor + + ## set smoothing tolerance + smtolx = 0.01*(max (max (real (rlpol))) - min (min (real (rlpol)))); + smtoly = 0.01*(max (max (imag (rlpol))) - min (min (imag (rlpol)))); + smtol = max (smtolx, smtoly); + ## sort according to nearest-neighbor + rlpol = sort_roots (rlpol, smtolx, smtoly); + + done = (nargin == 4); # perform a smoothness check + while (! done && ngain < 1000) + done = 1 ; # assume done + dp = abs (diff (rlpol'))'; + maxdp = max (dp); + + ## search for poles whose neighbors are distant + if (lden == 2) + idx = find (dp > smtol); + else + idx = find (maxdp > smtol); + endif + + for ii = 1:length(idx) + i1 = idx(ii); + g1 = gvec(i1); + p1 = rlpol(:,i1); + + i2 = idx(ii)+1; + g2 = gvec(i2); + p2 = rlpol(:,i2); + + ## isolate poles in p1, p2 + if (max (abs (p2-p1)) > smtol) + newg = linspace (g1, g2, 5); + newg = newg(2:4); + gvec = [gvec,newg]; + done = 0; # need to process new gains + endif + endfor + + ## process new gain values + ngain1 = length (gvec); + for ii = (ngain+1):ngain1 + gain = gvec(ii); + rlpol(1:nroots,ii) = vec(sort (roots (den + gain*num))); + endfor + + [gvec, idx] = sort (gvec); + rlpol = rlpol(:,idx); + ngain = length (gvec); + ## sort according to nearest-neighbor + rlpol = sort_roots (rlpol, smtolx, smtoly); + endwhile + rldata = rlpol; + + ## Plot the data + if (nargout == 0) + rlpolv = vec(rlpol); + axdata = [real(rlpolv), imag(rlpolv); real(olzer), imag(olzer)]; + axlim = __axis2dlim__ (axdata); + rldata = [real(rlpolv), imag(rlpolv) ]; + + %inname = get (sys, "inname"); + %outname = get (sys, "outname"); + + ## build plot command args pole by pole + + n_rlpol = rows (rlpol); + nelts = n_rlpol+1; + if (! isempty (rlzer)) + nelts++; + endif + # add asymptotes + n_A = length (olpol) - length (olzer); + if (n_A > 0) + nelts += n_A; + endif + args = cell (3, nelts); + kk = 0; + # asymptotes first + if (n_A > 0) + len_A = 2*max (abs (axlim)); + sigma_A = (sum(olpol) - sum(olzer))/n_A; + for i_A=0:n_A-1 + phi_A = pi*(2*i_A + 1)/n_A; + args{1,++kk} = [sigma_A sigma_A+len_A*cos(phi_A)]; + args{2,kk} = [0 len_A*sin(phi_A)]; + if (i_A == 1) + args{3,kk} = "k--;asymptotes;"; + else + args{3,kk} = "k--"; + endif + endfor + endif + # locus next + for ii = 1:rows(rlpol) + args{1,++kk} = real (rlpol (ii,:)); + args{2,kk} = imag (rlpol (ii,:)); + if (ii == 1) + args{3,kk} = "b-;locus;"; + else + args{3,kk} = "b-"; + endif + endfor + # poles and zeros last + args{1,++kk} = real (olpol); + args{2,kk} = imag (olpol); + args{3,kk} = "rx;open loop poles;"; + if (! isempty (rlzer)) + args{1,++kk} = real (rlzer); + args{2,kk} = imag (rlzer); + args{3,kk} = "go;zeros;"; + endif + + set (gcf,"visible","off"); + hplt = plot (args{:}); + set (hplt(kk--), "markersize", 2); + if (! isempty (rlzer)) + set (hplt(kk--), "markersize", 2); + endif + for ii = 1:rows(rlpol) + set (hplt(kk--), "linewidth", 2); + endfor + legend ("boxon", 2); + grid ("on"); + axis (axlim); + title ("Root Locus"); + xlabel (sprintf ("Real Axis gain = [%g, %g]", gvec(1), gvec(ngain))); + ylabel ("Imaginary Axis"); + set (gcf (), "visible","on"); + else + rldata_r = rldata; + endif +endfunction + + +function rlpol = sort_roots (rlpol,tolx, toly) + # no point sorting of you've only got one pole! + if (rows (rlpol) == 1) + return; + endif + + # reorder entries in each column of rlpol to be by their nearest-neighbors + dp = diff (rlpol')'; + drp = max (real (dp)); + dip = max (imag (dp)); + idx = find (drp > tolx | dip > toly); + if (isempty (idx)) + return; + endif + + [np, ng] = size (rlpol); # num poles, num gains + for jj = idx + vals = rlpol(:,[jj,jj+1]); + jdx = (jj+1):ng; + for ii = 1:rows(rlpol-1) + rdx = ii:np; + dval = abs (rlpol(rdx,jj+1)-rlpol(ii,jj)); + mindist = min (dval); + sidx = min (find (dval == mindist)) + ii - 1; + if (sidx != ii) + c1 = norm (diff(vals')); + [vals(ii,2), vals(sidx,2)] = swap (vals(ii,2), vals(sidx,2)); + c2 = norm (diff (vals')); + if (c1 > c2) + ## perform the swap + [rlpol(ii,jdx), rlpol(sidx,jdx)] = swap (rlpol(ii,jdx), rlpol(sidx,jdx)); + vals = rlpol(:,[jj,jj+1]); + endif + endif + endfor + endfor + +endfunction + + +function [a1, b1] = swap (a, b) + + a1 = b; + b1 = a; + +endfunction This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <par...@us...> - 2010-01-04 06:13:20
|
Revision: 6699 http://octave.svn.sourceforge.net/octave/?rev=6699&view=rev Author: paramaniac Date: 2010-01-04 06:13:12 +0000 (Mon, 04 Jan 2010) Log Message: ----------- control-oo: add example model of Westland Lynx helicopter Modified Paths: -------------- trunk/octave-forge/extra/control-oo/INDEX Added Paths: ----------- trunk/octave-forge/extra/control-oo/inst/WestlandLynx.m Modified: trunk/octave-forge/extra/control-oo/INDEX =================================================================== --- trunk/octave-forge/extra/control-oo/INDEX 2010-01-03 22:33:41 UTC (rev 6698) +++ trunk/octave-forge/extra/control-oo/INDEX 2010-01-04 06:13:12 UTC (rev 6699) @@ -1,6 +1,8 @@ control >> Control Theory Examples and Demos + Boeing707 optiPID + WestlandLynx Linear Models set ss Added: trunk/octave-forge/extra/control-oo/inst/WestlandLynx.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/WestlandLynx.m (rev 0) +++ trunk/octave-forge/extra/control-oo/inst/WestlandLynx.m 2010-01-04 06:13:12 UTC (rev 6699) @@ -0,0 +1,94 @@ +## -*- texinfo -*- +## @deftypefn{Function File} {@var{sys} =} WestlandLynx () +## Model of the Westland Lynx Helicopter about hover. +## @example +## @group +## INPUTS +## main rotor collective +## longitudinal cyclic +## lateral cyclic +## tail rotor collective +## +## STATES +## pitch attitude theta +## roll attitude phi +## roll rate (body-axis) p +## pitch rate (body-axis) q +## yaw rate xi +## forward velocity v_x +## lateral velocity v_y +## vertical velocity v_z +## +## OUTPUTS +## heave velocity H_dot +## pitch attitude theta +## roll attitude phi +## heading rate psi_dot +## roll rate p +## pitch rate q +## +## Reference: +## Skogestad, S. and Postlethwaite I. +## Multivariable Feedback Control: Analysis and Design +## Second Edition +## Wiley 2005 +## http://www.nt.ntnu.no/users/skoge/book/2nd_edition/matlab_m/matfiles.html +## @end group +## @end example +## @end deftypefn + +## Author: Lukas Reichlin <luk...@gm...> +## Created: January 2010 +## Version: 0.1 + +function sys = WestlandLynx () + + if (nargin) + print_usage (); + endif + + a01 = [ 0 0 0 0.99857378005981; + 0 0 1.00000000000000 -0.00318221934140; + 0 0 -11.57049560546880 -2.54463768005371; + 0 0 0.43935656547546 -1.99818229675293; + 0 0 -2.04089546203613 -0.45899915695190; + -32.10360717773440 0 -0.50335502624512 2.29785919189453; + 0.10216116905212 32.05783081054690 -2.34721755981445 -0.50361156463623; + -1.91097259521484 1.71382904052734 -0.00400543212891 -0.05741119384766]; + + a02 = [ 0.05338427424431 0 0 0; + 0.05952465534210 0 0 0; + -0.06360262632370 0.10678052902222 -0.09491866827011 0.00710757449269; + 0 0.01665188372135 0.01846204698086 -0.00118747074157; + -0.73502779006958 0.01925575733185 -0.00459562242031 0.00212036073208; + 0 -0.02121581137180 -0.02116791903973 0.01581159234047; + 0.83494758605957 0.02122657001019 -0.03787973523140 0.00035400385968; + 0 0.01398963481188 -0.00090675335377 -0.29051351547241]; + + a0 = [a01 a02]; + + b0 = [ 0 0 0 0; + 0 0 0 0; + 0.12433505058289 0.08278584480286 -2.75247764587402 -0.01788876950741; + -0.03635892271996 0.47509527206421 0.01429074257612 0; + 0.30449151992798 0.01495801657438 -0.49651837348938 -0.20674192905426; + 0.28773546218872 -0.54450607299805 -0.01637935638428 0; + -0.01907348632812 0.01636743545532 -0.54453611373901 0.23484230041504; + -4.82063293457031 -0.00038146972656 0 0]; + + c0 = [ 0 0 0 0 0 0.0595 0.05329 -0.9968; + 1.0 0 0 0 0 0 0 0; + 0 1.0 0 0 0 0 0 0; + 0 0 0 -0.05348 1.0 0 0 0; + 0 0 1.0 0 0 0 0 0; + 0 0 0 1.0 0 0 0 0]; + + d0 = zeros (6, 4); + + inname = {"main_coll", "long_cyc", "lat_cyc", "tail_coll"}; + stname = {"theta", "phi", "p", "q", "xi", "v_x", "v_y", "v_z"}; + outname = {"H_dot", "theta", "phi", "psi_dot", "p", "q"}; + + sys = ss (a0, b0, c0, d0, "inname", inname, "stname", stname, "outname", outname); + +endfunction This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <par...@us...> - 2010-01-09 14:32:52
|
Revision: 6723 http://octave.svn.sourceforge.net/octave/?rev=6723&view=rev Author: paramaniac Date: 2010-01-09 14:32:44 +0000 (Sat, 09 Jan 2010) Log Message: ----------- control-oo: add draft code for lyap/dlyap Modified Paths: -------------- trunk/octave-forge/extra/control-oo/inst/dlyap.m trunk/octave-forge/extra/control-oo/inst/gram.m trunk/octave-forge/extra/control-oo/inst/lyap.m trunk/octave-forge/extra/control-oo/src/Makefile Added Paths: ----------- trunk/octave-forge/extra/control-oo/src/MB01RD.f trunk/octave-forge/extra/control-oo/src/SB03MD.f trunk/octave-forge/extra/control-oo/src/slsb03md.cc Modified: trunk/octave-forge/extra/control-oo/inst/dlyap.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/dlyap.m 2010-01-08 22:12:45 UTC (rev 6722) +++ trunk/octave-forge/extra/control-oo/inst/dlyap.m 2010-01-09 14:32:44 UTC (rev 6723) @@ -1,159 +1,55 @@ -## Copyright (C) 1993, 1994, 1995, 2000, 2002, 2004, 2005, 2007 -## Auburn University. All rights reserved. +## Copyright (C) 2010 Lukas F. Reichlin ## +## This file is part of LTI Syncope. ## -## 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. +## LTI Syncope 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. +## LTI Syncope 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; see the file COPYING. If not, see -## <http://www.gnu.org/licenses/>. +## along with this program. If not, see <http://www.gnu.org/licenses/>. ## -*- texinfo -*- -## @deftypefn {Function File} {} dlyap (@var{a}, @var{b}) -## Solve the discrete-time Lyapunov equation -## -## @strong{Inputs} -## @table @var -## @item a -## @var{n} by @var{n} matrix; -## @item b -## Matrix: @var{n} by @var{n}, @var{n} by @var{m}, or @var{p} by @var{n}. -## @end table -## -## @strong{Output} -## @table @var -## @item x -## matrix satisfying appropriate discrete time Lyapunov equation. -## @end table -## -## Options: -## @itemize @bullet -## @item @var{b} is square: solve -## @iftex -## @tex -## $$ axa^T - x + b = 0 $$ -## @end tex -## @end iftex -## @ifinfo -## @code{a x a' - x + b = 0} -## @end ifinfo -## @item @var{b} is not square: @var{x} satisfies either -## @iftex -## @tex -## $$ axa^T - x + bb^T = 0 $$ -## @end tex -## @end iftex -## @ifinfo +## @deftypefn{Function File} {@var{x} =} dlyap (@var{a}, @var{q}) +## ## @example -## a x a' - x + b b' = 0 -## @end example -## @end ifinfo -## @noindent -## or -## @iftex -## @tex -## $$ a^Txa - x + b^Tb = 0, $$ -## @end tex -## @end iftex -## @ifinfo -## @example -## a' x a - x + b' b = 0, -## @end example -## @end ifinfo -## @noindent -## whichever is appropriate. -## @end itemize +## @group ## -## @strong{Method} -## Uses Schur decomposition method as in Kitagawa, -## @cite{An Algorithm for Solving the Matrix Equation @math{X = F X F' + S}}, -## International Journal of Control, Volume 25, Number 5, pages 745--753 -## (1977). -## -## Column-by-column solution method as suggested in -## Hammarling, @cite{Numerical Solution of the Stable, Non-Negative -## Definite Lyapunov Equation}, @acronym{IMA} Journal of Numerical Analysis, Volume -## 2, pages 303--323 (1982). +## @end group +## @end example ## @end deftypefn -## Author: A. S. Hodel <a.s...@en...> -## Created: August 1993 +## Author: Lukas Reichlin <luk...@gm...> +## Created: January 2010 +## Version: 0.1 -function x = dlyap (a, b) +function x = dlyap (a, q) if (nargin != 2) print_usage (); endif - if ((n = issquare (a)) == 0) - warning ("dlyap: a must be square"); + na = issquare (a); + nq = issquare (q); + + if (! na) + error ("lyap: a must be square"); endif - if ((m = issquare (b)) == 0) - [n1, m] = size (b); - if (n1 == n) - b = b*b'; - m = n1; - else - b = b'*b; - a = a'; - endif + if (! nq) + error ("lyap: q must be square") endif - - if (n != m) - warning ("dlyap: a,b not conformably dimensioned"); + + if (na != nq) + error ("lyap: a and q must be of identical size"); endif + + x = slsb03md (a, -q, true); - ## Solve the equation column by column. - - [u, s] = schur (a); - b = u'*b*u; - - j = n; - while (j > 0) - j1 = j; - - ## Check for Schur block. - - if (j == 1) - blksiz = 1; - elseif (s (j, j-1) != 0) - blksiz = 2; - j = j - 1; - else - blksiz = 1; - endif - - Ajj = kron (s(j:j1,j:j1), s) - eye (blksiz*n); - - rhs = reshape (b (:,j:j1), blksiz*n, 1); - - if (j1 < n) - rhs2 = s*(x(:,(j1+1):n) * s(j:j1,(j1+1):n)'); - rhs = rhs + reshape (rhs2, blksiz*n, 1); - endif - - v = - Ajj\rhs; - x(:,j) = v (1:n); - - if (blksiz == 2) - x (:, j1) = v ((n+1):blksiz*n); - endif - - j = j - 1; - - endwhile - - ## Back-transform to original coordinates. - - x = u*x*u'; - endfunction Modified: trunk/octave-forge/extra/control-oo/inst/gram.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/gram.m 2010-01-08 22:12:45 UTC (rev 6722) +++ trunk/octave-forge/extra/control-oo/inst/gram.m 2010-01-09 14:32:44 UTC (rev 6723) @@ -71,7 +71,7 @@ endif if (isct (sys)) - W = lyap (a', b*b'); # let lyap do the error checking about dimensions + W = lyap (a, b*b'); # let lyap do the error checking about dimensions else # discrete-time system W = dlyap (a, b*b'); # let dlyap do the error checking about dimensions endif Modified: trunk/octave-forge/extra/control-oo/inst/lyap.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/lyap.m 2010-01-08 22:12:45 UTC (rev 6722) +++ trunk/octave-forge/extra/control-oo/inst/lyap.m 2010-01-09 14:32:44 UTC (rev 6723) @@ -1,141 +1,64 @@ -## Copyright (C) 1996, 1997, 2000, 2002, 2004, 2005, 2006, 2007 -## Auburn University. All rights reserved. +## Copyright (C) 2010 Lukas F. Reichlin ## +## This file is part of LTI Syncope. ## -## 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. +## LTI Syncope 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. +## LTI Syncope 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; see the file COPYING. If not, see -## <http://www.gnu.org/licenses/>. +## along with this program. If not, see <http://www.gnu.org/licenses/>. ## -*- texinfo -*- -## @deftypefn {Function File} {} lyap (@var{a}, @var{b}, @var{c}) -## @deftypefnx {Function File} {} lyap (@var{a}, @var{b}) -## Solve the Lyapunov (or Sylvester) equation via the Bartels-Stewart -## algorithm (Communications of the @acronym{ACM}, 1972). -## -## If @var{a}, @var{b}, and @var{c} are specified, then @code{lyap} returns -## the solution of the Sylvester equation -## @iftex -## @tex -## $$ A X + X B + C = 0 $$ -## @end tex -## @end iftex -## @ifinfo +## @deftypefn{Function File} {@var{x} =} lyap (@var{a}, @var{q}) +## ## @example -## a x + x b + c = 0 -## @end example -## @end ifinfo -## If only @code{(a, b)} are specified, then @command{lyap} returns the -## solution of the Lyapunov equation -## @iftex -## @tex -## $$ A^T X + X A + B = 0 $$ -## @end tex -## @end iftex -## @ifinfo -## @example -## a' x + x a + b = 0 -## @end example -## @end ifinfo -## If @var{b} is not square, then @code{lyap} returns the solution of either -## @iftex -## @tex -## $$ A^T X + X A + B^T B = 0 $$ -## @end tex -## @end iftex -## @ifinfo -## @example -## a' x + x a + b' b = 0 -## @end example -## @end ifinfo -## @noindent -## or -## @iftex -## @tex -## $$ A X + X A^T + B B^T = 0 $$ -## @end tex -## @end iftex -## @ifinfo -## @example -## a x + x a' + b b' = 0 -## @end example -## @end ifinfo -## @noindent -## whichever is appropriate. +## @group ## -## Solves by using the Bartels-Stewart algorithm (1972). +## @end group +## @end example ## @end deftypefn -## Author: A. S. Hodel <a.s...@en...> -## Created: August 1993 -## Adapted-By: jwe +## Author: Lukas Reichlin <luk...@gm...> +## Created: January 2010 +## Version: 0.1 -function x = lyap (a, b, c) +function x = lyap (a, q) - if (nargin != 3 && nargin != 2) + if (nargin != 2) print_usage (); endif - if ((n = issquare(a)) == 0) - error ("lyap: a is not square"); + na = issquare (a); + nq = issquare (q); + + if (! na) + error ("lyap: a must be square"); endif - if (nargin == 2) - - ## Transform Lyapunov equation to Sylvester equation form. - - if ((m = issquare (b)) == 0) - if ((m = rows (b)) == n) - - ## solve a x + x a' + b b' = 0 - - b = b * b'; - a = a'; - else - - ## Try to solve a'x + x a + b' b = 0. - - m = columns (b); - b = b' * b; - endif - - if (m != n) - error ("lyap: a, b not conformably dimensioned"); - endif - endif - - ## Set up Sylvester equation. - - c = b; - b = a; - a = b'; - - else - - ## Check dimensions. - - if ((m = issquare (b)) == 0) - error ("lyap: b must be square in a sylvester equation"); - endif - - [n1, m1] = size(c); - - if (n != n1 || m != m1) - error("lyap: a, b, c not conformably dimensioned"); - endif + if (! nq) + error ("lyap: q must be square") endif + + if (na != nq) + error ("lyap: a and q must be of identical size"); + endif + + x = slsb03md (a, -q, false); - ## Call octave built-in function. +endfunction - x = syl (a, b, c); -endfunction +%!shared X, X_exp +%! A = [1, 2; -3, -4]; +%! Q = [3, 1; 1, 1]; +%! X = lyap (A, Q); +%! X_exp = [ 6.1667, -3.8333; +%! -3.8333, 3.0000]; +%!assert (X, X_exp, 1e-4); \ No newline at end of file Added: trunk/octave-forge/extra/control-oo/src/MB01RD.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/MB01RD.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/MB01RD.f 2010-01-09 14:32:44 UTC (rev 6723) @@ -0,0 +1,345 @@ + SUBROUTINE MB01RD( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA, + $ X, LDX, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To compute the matrix formula +C _ +C R = alpha*R + beta*op( A )*X*op( A )', +C _ +C where alpha and beta are scalars, R, X, and R are symmetric +C matrices, A is a general matrix, and op( A ) is one of +C +C op( A ) = A or op( A ) = A'. +C +C The result is overwritten on R. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 _ +C Specifies which triangles of the symmetric matrices R, R, +C and X are given as follows: +C = 'U': the upper triangular part is given; +C = 'L': the lower triangular part is given. +C +C TRANS CHARACTER*1 +C Specifies the form of op( A ) to be used in the matrix +C multiplication as follows: +C = 'N': op( A ) = A; +C = 'T': op( A ) = A'; +C = 'C': op( A ) = A'. +C +C Input/Output Parameters +C +C M (input) INTEGER _ +C The order of the matrices R and R and the number of rows +C of the matrix op( A ). M >= 0. +C +C N (input) INTEGER +C The order of the matrix X and the number of columns of the +C the matrix op( A ). N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then R need not be +C set before entry, except when R is identified with X in +C the call (which is possible only in this case). +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then A and X are not +C referenced. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) +C On entry with UPLO = 'U', the leading M-by-M upper +C triangular part of this array must contain the upper +C triangular part of the symmetric matrix R; the strictly +C lower triangular part of the array is used as workspace. +C On entry with UPLO = 'L', the leading M-by-M lower +C triangular part of this array must contain the lower +C triangular part of the symmetric matrix R; the strictly +C upper triangular part of the array is used as workspace. +C On exit, the leading M-by-M upper triangular part (if +C UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of +C this array contains the corresponding triangular part of +C _ +C the computed matrix R. If beta <> 0, the remaining +C strictly triangular part of this array contains the +C corresponding part of the matrix expression +C beta*op( A )*T*op( A )', where T is the triangular matrix +C defined in the Method section. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,M). +C +C A (input) DOUBLE PRECISION array, dimension (LDA,k) +C where k is N when TRANS = 'N' and is M when TRANS = 'T' or +C TRANS = 'C'. +C On entry with TRANS = 'N', the leading M-by-N part of this +C array must contain the matrix A. +C On entry with TRANS = 'T' or TRANS = 'C', the leading +C N-by-M part of this array must contain the matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,l), +C where l is M when TRANS = 'N' and is N when TRANS = 'T' or +C TRANS = 'C'. +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, if UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular part of the symmetric matrix X and the strictly +C lower triangular part of the array is not referenced. +C On entry, if UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular part of the symmetric matrix X and the strictly +C upper triangular part of the array is not referenced. +C On exit, each diagonal element of this array has half its +C input value, but the other elements are not modified. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= MAX(1,N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, the leading M-by-N part of this +C array (with the leading dimension MAX(1,M)) returns the +C matrix product beta*op( A )*T, where T is the triangular +C matrix defined in the Method section. +C This array is not referenced when beta = 0. +C +C LDWORK The length of the array DWORK. +C LDWORK >= MAX(1,M*N), if beta <> 0; +C LDWORK >= 1, if beta = 0. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -k, the k-th argument had an illegal +C value. +C +C METHOD +C +C The matrix expression is efficiently evaluated taking the symmetry +C into account. Specifically, let X = T + T', with T an upper or +C lower triangular matrix, defined by +C +C T = triu( X ) - (1/2)*diag( X ), if UPLO = 'U', +C T = tril( X ) - (1/2)*diag( X ), if UPLO = 'L', +C +C where triu, tril, and diag denote the upper triangular part, lower +C triangular part, and diagonal part of X, respectively. Then, +C +C op( A )*X*op( A )' = B + B', +C +C where B := op( A )*T*op( A )'. Matrix B is not symmetric, but it +C can be written as tri( B ) + stri( B ), where tri denotes the +C triangular part specified by UPLO, and stri denotes the remaining +C strictly triangular part. Let R = V + V', with V defined as T +C above. Then, the required triangular part of the result can be +C written as +C +C alpha*V + beta*tri( B ) + beta*(stri( B ))' + +C alpha*diag( V ) + beta*diag( tri( B ) ). +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately +C +C 2 2 +C 3/2 x M x N + 1/2 x M +C +C operations. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004, +C Apr. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D0 ) +C .. Scalar Arguments .. + CHARACTER TRANS, UPLO + INTEGER INFO, LDA, LDR, LDWORK, LDX, M, N + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), R(LDR,*), X(LDX,*) +C .. Local Scalars .. + CHARACTER*12 NTRAN + LOGICAL LTRANS, LUPLO + INTEGER J, JWORK, LDW, NROWA +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DLACPY, DLASCL, DLASET, + $ DSCAL, DTRMM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LUPLO = LSAME( UPLO, 'U' ) + LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + IF ( LTRANS ) THEN + NROWA = N + NTRAN = 'No transpose' + ELSE + NROWA = M + NTRAN = 'Transpose' + END IF +C + LDW = MAX( 1, M ) +C + IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN + INFO = -1 + ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDR.LT.LDW ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN + INFO = -10 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( ( BETA.NE.ZERO .AND. LDWORK.LT.MAX( 1, M*N ) ) + $ .OR.( BETA.EQ.ZERO .AND. LDWORK.LT.1 ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + CALL DSCAL( N, HALF, X, LDX+1 ) + IF ( M.EQ.0 ) + $ RETURN +C + IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN + IF ( ALPHA.EQ.ZERO ) THEN +C +C Special case alpha = 0. +C + CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) + ELSE +C +C Special case beta = 0 or N = 0. +C + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) + END IF + RETURN + END IF +C +C General case: beta <> 0. Efficiently compute +C _ +C R = alpha*R + beta*op( A )*X*op( A )', +C +C as described in the Method section. +C +C Compute W = beta*op( A )*T in DWORK. +C Workspace: need M*N. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code.) +C + IF( LTRANS ) THEN + JWORK = 1 +C + DO 10 J = 1, N + CALL DCOPY( M, A(J,1), LDA, DWORK(JWORK), 1 ) + JWORK = JWORK + LDW + 10 CONTINUE +C + ELSE + CALL DLACPY( 'Full', M, N, A, LDA, DWORK, LDW ) + END IF +C + CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', M, N, BETA, + $ X, LDX, DWORK, LDW ) +C +C Compute Y = alpha*V + W*op( A )' in R. First, set to zero the +C strictly triangular part of R not specified by UPLO. That part +C will then contain beta*stri( B ). +C + IF ( ALPHA.NE.ZERO ) THEN + IF ( M.GT.1 ) THEN + IF ( LUPLO ) THEN + CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, R(2,1), LDR ) + ELSE + CALL DLASET( 'Upper', M-1, M-1, ZERO, ZERO, R(1,2), LDR ) + END IF + END IF + CALL DSCAL( M, HALF, R, LDR+1 ) + END IF +C + CALL DGEMM( 'No transpose', NTRAN, M, M, N, ONE, DWORK, LDW, A, + $ LDA, ALPHA, R, LDR ) +C +C Add the term corresponding to B', with B = op( A )*T*op( A )'. +C + IF( LUPLO ) THEN +C + DO 20 J = 1, M + CALL DAXPY( J, ONE, R(J,1), LDR, R(1,J), 1 ) + 20 CONTINUE +C + ELSE +C + DO 30 J = 1, M + CALL DAXPY( J, ONE, R(1,J), 1, R(J,1), LDR ) + 30 CONTINUE +C + END IF +C + RETURN +C *** Last line of MB01RD *** + END Modified: trunk/octave-forge/extra/control-oo/src/Makefile =================================================================== --- trunk/octave-forge/extra/control-oo/src/Makefile 2010-01-08 22:12:45 UTC (rev 6722) +++ trunk/octave-forge/extra/control-oo/src/Makefile 2010-01-09 14:32:44 UTC (rev 6723) @@ -1,5 +1,5 @@ all: slab08nd.oct slab13dd.oct slsb10hd.oct slsb10ed.oct slab13bd.oct \ - slsb01bd.oct slsb10fd.oct slsb10dd.oct + slsb01bd.oct slsb10fd.oct slsb10dd.oct slsb03md.oct # transmission zeros of state-space models slab08nd.oct: slab08nd.cc @@ -68,5 +68,11 @@ SB03MX.f SB02MR.f SB02MV.f MB01UD.f SB03MV.f \ SB04PX.f +# Lyapunov equations +slsb03md.oct: slsb03md.cc + mkoctfile slsb03md.cc \ + SB03MD.f select.f SB03MX.f SB03MY.f MB01RD.f \ + SB03MV.f SB03MW.f SB04PX.f + clean: rm *.o core octave-core *.oct *~ Added: trunk/octave-forge/extra/control-oo/src/SB03MD.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/SB03MD.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/SB03MD.f 2010-01-09 14:32:44 UTC (rev 6723) @@ -0,0 +1,556 @@ + SUBROUTINE SB03MD( DICO, JOB, FACT, TRANA, N, A, LDA, U, LDU, C, + $ LDC, SCALE, SEP, FERR, WR, WI, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To solve for X either the real continuous-time Lyapunov equation +C +C op(A)'*X + X*op(A) = scale*C (1) +C +C or the real discrete-time Lyapunov equation +C +C op(A)'*X*op(A) - X = scale*C (2) +C +C and/or estimate an associated condition number, called separation, +C where op(A) = A or A' (A**T) and C is symmetric (C = C'). +C (A' denotes the transpose of the matrix A.) A is N-by-N, the right +C hand side C and the solution X are N-by-N, and scale is an output +C scale factor, set less than or equal to 1 to avoid overflow in X. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the equation from which X is to be determined +C as follows: +C = 'C': Equation (1), continuous-time case; +C = 'D': Equation (2), discrete-time case. +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'X': Compute the solution only; +C = 'S': Compute the separation only; +C = 'B': Compute both the solution and the separation. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, A and U contain the factors from the +C real Schur factorization of the matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in A and U. +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X, and C. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. If FACT = 'F', then A contains +C an upper quasi-triangular matrix in Schur canonical form; +C the elements below the upper Hessenberg part of the +C array A are not referenced. +C On exit, if INFO = 0 or INFO = N+1, the leading N-by-N +C upper Hessenberg part of this array contains the upper +C quasi-triangular matrix in Schur canonical form from the +C Schur factorization of A. The contents of array A is not +C modified if FACT = 'F'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,N) +C If FACT = 'F', then U is an input argument and on entry +C the leading N-by-N part of this array must contain the +C orthogonal matrix U of the real Schur factorization of A. +C If FACT = 'N', then U is an output argument and on exit, +C if INFO = 0 or INFO = N+1, it contains the orthogonal +C N-by-N matrix from the real Schur factorization of A. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry with JOB = 'X' or 'B', the leading N-by-N part of +C this array must contain the symmetric matrix C. +C On exit with JOB = 'X' or 'B', if INFO = 0 or INFO = N+1, +C the leading N-by-N part of C has been overwritten by the +C symmetric solution matrix X. +C If JOB = 'S', C is not referenced. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= 1, if JOB = 'S'; +C LDC >= MAX(1,N), otherwise. +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C SEP (output) DOUBLE PRECISION +C If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1, SEP +C contains the estimated separation of the matrices op(A) +C and -op(A)', if DICO = 'C' or of op(A) and op(A)', if +C DICO = 'D'. +C If JOB = 'X' or N = 0, SEP is not referenced. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains an +C estimated forward error bound for the solution X. +C If XTRUE is the true solution, FERR bounds the relative +C error in the computed solution, measured in the Frobenius +C norm: norm(X - XTRUE)/norm(XTRUE). +C If JOB = 'X' or JOB = 'S', FERR is not referenced. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI +C contain the real and imaginary parts, respectively, of +C the eigenvalues of A. +C If FACT = 'F', WR and WI are not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C This array is not referenced if JOB = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 1, and +C If JOB = 'X' then +C If FACT = 'F', LDWORK >= N*N, for DICO = 'C'; +C LDWORK >= MAX(N*N, 2*N), for DICO = 'D'; +C If FACT = 'N', LDWORK >= MAX(N*N, 3*N). +C If JOB = 'S' or JOB = 'B' then +C If FACT = 'F', LDWORK >= 2*N*N, for DICO = 'C'; +C LDWORK >= 2*N*N + 2*N, for DICO = 'D'. +C If FACT = 'N', LDWORK >= MAX(2*N*N, 3*N), DICO = 'C'; +C LDWORK >= 2*N*N + 2*N, for DICO = 'D'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, the QR algorithm failed to compute all +C the eigenvalues (see LAPACK Library routine DGEES); +C elements i+1:n of WR and WI contain eigenvalues +C which have converged, and A contains the partially +C converged Schur form; +C = N+1: if DICO = 'C', and the matrices A and -A' have +C common or very close eigenvalues, or +C if DICO = 'D', and matrix A has almost reciprocal +C eigenvalues (that is, lambda(i) = 1/lambda(j) for +C some i and j, where lambda(i) and lambda(j) are +C eigenvalues of A and i <> j); perturbed values were +C used to solve the equation (but the matrix A is +C unchanged). +C +C METHOD +C +C The Schur factorization of a square matrix A is given by +C +C A = U*S*U' +C +C where U is orthogonal and S is block upper triangular with 1-by-1 +C and 2-by-2 blocks on its diagonal, these blocks corresponding to +C the eigenvalues of A, the 2-by-2 blocks being complex conjugate +C pairs. This factorization is obtained by numerically stable +C methods: first A is reduced to upper Hessenberg form (if FACT = +C 'N') by means of Householder transformations and then the +C QR Algorithm is applied to reduce the Hessenberg form to S, the +C transformation matrices being accumulated at each step to give U. +C If A has already been factorized prior to calling the routine +C however, then the factors U and S may be supplied and the initial +C factorization omitted. +C _ _ +C If we now put C = U'CU and X = UXU' equations (1) and (2) (see +C PURPOSE) become (for TRANS = 'N') +C _ _ _ +C S'X + XS = C, (3) +C and +C _ _ _ +C S'XS - X = C, (4) +C +C respectively. Partition S, C and X as +C _ _ _ _ +C (s s') (c c') (x x') +C ( 11 ) _ ( 11 ) _ ( 11 ) +C S = ( ), C = ( ), X = ( ) +C ( ) ( _ ) ( _ ) +C ( 0 S ) ( c C ) ( x X ) +C 1 1 1 +C _ _ +C where s , c and x are either scalars or 2-by-2 matrices and s, +C 11 11 11 +C _ _ +C c and x are either (N-1) element vectors or matrices with two +C columns. Equations (3) and (4) can then be re-written as +C _ _ _ +C s' x + x s = c (3.1) +C 11 11 11 11 11 +C +C _ _ _ _ +C S'x + xs = c - sx (3.2) +C 1 11 11 +C +C _ _ +C S'X + X S = C - (sx' + xs') (3.3) +C 1 1 1 1 1 +C and +C _ _ _ +C s' x s - x = c (4.1) +C 11 11 11 11 11 +C +C _ _ _ _ +C S'xs - x = c - sx s (4.2) +C 1 11 11 11 +C +C _ _ _ +C S'X S - X = C - sx s' - [s(S'x)' + (S'x)s'] (4.3) +C 1 1 1 1 1 11 1 1 +C _ +C respectively. If DICO = 'C' ['D'], then once x has been +C 11 +C found from equation (3.1) [(4.1)], equation (3.2) [(4.2)] can be +C _ +C solved by forward substitution for x and then equation (3.3) +C [(4.3)] is of the same form as (3) [(4)] but of the order (N-1) or +C (N-2) depending upon whether s is 1-by-1 or 2-by-2. +C 11 +C _ _ +C When s is 2-by-2 then x and c will be 1-by-2 matrices and s, +C 11 11 11 +C _ _ +C x and c are matrices with two columns. In this case, equation +C (3.1) [(4.1)] defines the three equations in the unknown elements +C _ +C of x and equation (3.2) [(4.2)] can then be solved by forward +C 11 _ +C substitution, a row of x being found at each step. +C +C REFERENCES +C +C [1] Barraud, A.Y. T +C A numerical algorithm to solve A XA - X = Q. +C IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977. +C +C [2] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [3] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-325, 1982. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C If DICO = 'C', SEP is defined as the separation of op(A) and +C -op(A)': +C +C sep( op(A), -op(A)' ) = sigma_min( T ) +C +C and if DICO = 'D', SEP is defined as +C +C sep( op(A), op(A)' ) = sigma_min( T ) +C +C where sigma_min(T) is the smallest singular value of the +C N*N-by-N*N matrix +C +C T = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) ) (DICO = 'C'), +C +C T = kprod( op(A)', op(A)' ) - I(N**2) (DICO = 'D'). +C +C I(x) is an x-by-x identity matrix, and kprod denotes the Kronecker +C product. The program estimates sigma_min(T) by the reciprocal of +C an estimate of the 1-norm of inverse(T). The true reciprocal +C 1-norm of inverse(T) cannot differ from sigma_min(T) by more +C than a factor of N. +C +C When SEP is small, small changes in A, C can cause large changes +C in the solution of the equation. An approximate bound on the +C maximum relative error in the computed solution is +C +C EPS * norm(A) / SEP (DICO = 'C'), +C +C EPS * norm(A)**2 / SEP (DICO = 'D'), +C +C where EPS is the machine precision. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, July 1997. +C Supersedes Release 2.0 routine SB03AD by Control Systems Research +C Group, Kingston Polytechnic, United Kingdom. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, FACT, JOB, TRANA + INTEGER INFO, LDA, LDC, LDU, LDWORK, N + DOUBLE PRECISION FERR, SCALE, SEP +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), + $ U( LDU, * ), WI( * ), WR( * ) +C .. Local Scalars .. + LOGICAL CONT, NOFACT, NOTA, WANTBH, WANTSP, WANTX + CHARACTER NOTRA, NTRNST, TRANST, UPLO + INTEGER I, IERR, KASE, LWA, MINWRK, NN, NN2, SDIM + DOUBLE PRECISION EPS, EST, SCALEF +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. External Functions .. + LOGICAL LSAME, SELECT + DOUBLE PRECISION DLAMCH, DLANHS + EXTERNAL DLAMCH, DLANHS, LSAME, SELECT +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DLACON, MB01RD, SB03MX, SB03MY, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + CONT = LSAME( DICO, 'C' ) + WANTX = LSAME( JOB, 'X' ) + WANTSP = LSAME( JOB, 'S' ) + WANTBH = LSAME( JOB, 'B' ) + NOFACT = LSAME( FACT, 'N' ) + NOTA = LSAME( TRANA, 'N' ) + NN = N*N + NN2 = 2*NN +C + INFO = 0 + IF( .NOT.CONT .AND. .NOT.LSAME( DICO, 'D' ) ) THEN + INFO = -1 + ELSE IF( .NOT.WANTBH .AND. .NOT.WANTSP .AND. .NOT.WANTX ) THEN + INFO = -2 + ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -3 + ELSE IF( .NOT.NOTA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. + $ .NOT.LSAME( TRANA, 'C' ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( WANTSP .AND. LDC.LT.1 .OR. + $ .NOT.WANTSP .AND. LDC.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE + IF ( WANTX ) THEN + IF ( NOFACT ) THEN + MINWRK = MAX( NN, 3*N ) + ELSE IF ( CONT ) THEN + MINWRK = NN + ELSE + MINWRK = MAX( NN, 2*N ) + END IF + ELSE + IF ( CONT ) THEN + IF ( NOFACT ) THEN + MINWRK = MAX( NN2, 3*N ) + ELSE + MINWRK = NN2 + END IF + ELSE + MINWRK = NN2 + 2*N + END IF + END IF + IF( LDWORK.LT.MAX( 1, MINWRK ) ) + $ INFO = -19 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB03MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + SCALE = ONE + IF( WANTBH ) + $ FERR = ZERO + DWORK(1) = ONE + RETURN + END IF +C + LWA = 0 +C + IF( NOFACT ) THEN +C +C Compute the Schur factorization of A. +C Workspace: need 3*N; +C prefer larger. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + IF( INFO.GT.0 ) + $ RETURN + LWA = INT( DWORK( 1 ) ) + END IF +C + IF( .NOT.WANTSP ) THEN +C +C Transform the right-hand side. +C Workspace: N*N. +C + NTRNST = 'N' + TRANST = 'T' + UPLO = 'U' + CALL MB01RD( UPLO, TRANST, N, N, ZERO, ONE, C, LDC, U, LDU, C, + $ LDC, DWORK, LDWORK, INFO ) +C + DO 10 I = 2, N + CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) + 10 CONTINUE +C + LWA = MAX( LWA, NN ) +C +C Solve the transformed equation. +C Workspace for DICO = 'D': 2*N. +C + IF ( CONT ) THEN + CALL SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) + ELSE + CALL SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) + END IF + IF( INFO.GT.0 ) + $ INFO = N + 1 +C +C Transform back the solution. +C Workspace: N*N. +C + CALL MB01RD( UPLO, NTRNST, N, N, ZERO, ONE, C, LDC, U, LDU, C, + $ LDC, DWORK, LDWORK, IERR ) +C + DO 20 I = 2, N + CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) + 20 CONTINUE +C + END IF +C + IF( .NOT.WANTX ) THEN +C +C Estimate the separation. +C Workspace: 2*N*N for DICO = 'C'; +C 2*N*N + 2*N for DICO = 'D'. +C + IF( NOTA ) THEN + NOTRA = 'T' + ELSE + NOTRA = 'N' + END IF +C + EST = ZERO + KASE = 0 +C REPEAT + 30 CONTINUE + CALL DLACON( NN, DWORK(NN+1), DWORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.1 ) THEN + IF( CONT ) THEN + CALL SB03MY( TRANA, N, A, LDA, DWORK, N, SCALEF, + $ IERR ) + ELSE + CALL SB03MX( TRANA, N, A, LDA, DWORK, N, SCALEF, + $ DWORK(NN2+1), IERR ) + END IF + ELSE + IF( CONT ) THEN + CALL SB03MY( NOTRA, N, A, LDA, DWORK, N, SCALEF, + $ IERR ) + ELSE + CALL SB03MX( NOTRA, N, A, LDA, DWORK, N, SCALEF, + $ DWORK(NN2+1), IERR ) + END IF + END IF + GO TO 30 + END IF +C UNTIL KASE = 0 +C + SEP = SCALEF / EST +C + IF( WANTBH ) THEN +C +C Get the machine precision. +C + EPS = DLAMCH( 'P' ) +C +C Compute the estimate of the relative error. +C + IF ( CONT ) THEN + FERR = EPS*DLANHS( 'Frobenius', N, A, LDA, DWORK )/SEP + ELSE + FERR = EPS*DLANHS( 'Frobenius', N, A, LDA, DWORK )**2/SEP + END IF + END IF + END IF +C + DWORK( 1 ) = DBLE( MAX( LWA, MINWRK ) ) + RETURN +C *** Last line of SB03MD *** + END Added: trunk/octave-forge/extra/control-oo/src/slsb03md.cc =================================================================== --- trunk/octave-forge/extra/control-oo/src/slsb03md.cc (rev 0) +++ trunk/octave-forge/extra/control-oo/src/slsb03md.cc 2010-01-09 14:32:44 UTC (rev 6723) @@ -0,0 +1,142 @@ +/* + +Copyright (C) 2009 - 2010 Lukas F. Reichlin + +This file is part of LTI Syncope. + +LTI Syncope 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. + +LTI Syncope 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, see <http://www.gnu.org/licenses/>. + +Solution of Lyapunov equations. +Uses SLICOT SB03MD by courtesy of NICONET e.V. +<http://www.slicot.org> + +Author: Lukas Reichlin <luk...@gm...> +Created: December 2009 +Version: 0.2 + +*/ + +#include <octave/oct.h> +#include <f77-fcn.h> + +extern "C" +{ + int F77_FUNC (sb03md, SB03MD) + (char& DICO, char& JOB, + char& FACT, char& TRANA, + int& N, + double* A, int& LDA, + double* U, int& LDU, + double* C, int& LDC, + double& SCALE, + double& SEP, double& FERR, + double* WR, double* WI, + int* IWORK, + double* DWORK, int& LDWORK, + int& INFO); +} + +int max (int a, int b) +{ + if (a > b) + return a; + else + return b; +} + +DEFUN_DLD (slsb03md, args, nargout, "Slicot SB03MD Release 5.0") +{ + int nargin = args.length (); + octave_value_list retval; + + if (nargin != 3) + { + print_usage (); + } + else + { + // arguments in + char dico; + char job = 'X'; + char fact = 'N'; + char trana = 'T'; + + NDArray a = args(0).array_value (); + NDArray c = args(1).array_value (); + int dt = args(2).int_value (); + + if (dt == 0) + dico = 'C'; + else + dico = 'D'; + + int n = a.rows (); // n: number of states + + int lda = max (1, n); + int ldu = max (1, n); + int ldc = max (1, n); + + // arguments out + double scale; + double sep = 0; + double ferr = 0; + + dim_vector dv_u (2); + dv_u(0) = ldu; + dv_u(1) = n; + + dim_vector dv (1); + dv(0) = n; + + NDArray u (dv_u); + NDArray wr (dv); + NDArray wi (dv); + + // workspace + int* iwork = 0; // not referenced because job = X + + int ldwork = max (n*n, 3*n); + OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); + + // error indicator + int info; + + + // SLICOT routine SB03MD + F77_XFCN (sb03md, SB03MD, + (dico, job, + fact, trana, + n, + a.fortran_vec (), lda, + u.fortran_vec (), ldu, + c.fortran_vec (), ldc, + scale, + sep, ferr, + wr.fortran_vec (), wi.fortran_vec (), + iwork, + dwork, ldwork, + info)); + + if (f77_exception_encountered) + error ("lyap: slsb03md: exception in SLICOT subroutine SB03MD"); + + if (info != 0) + error ("lyap: slsb03md: SB03MD returned info = %d", info); + + // return values + retval(0) = c; + } + + return retval; +} This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <par...@us...> - 2010-01-09 16:14:28
|
Revision: 6724 http://octave.svn.sourceforge.net/octave/?rev=6724&view=rev Author: paramaniac Date: 2010-01-09 16:14:15 +0000 (Sat, 09 Jan 2010) Log Message: ----------- control-oo: add covar.m Modified Paths: -------------- trunk/octave-forge/extra/control-oo/INDEX Added Paths: ----------- trunk/octave-forge/extra/control-oo/inst/covar.m Modified: trunk/octave-forge/extra/control-oo/INDEX =================================================================== --- trunk/octave-forge/extra/control-oo/INDEX 2010-01-09 14:32:44 UTC (rev 6723) +++ trunk/octave-forge/extra/control-oo/INDEX 2010-01-09 16:14:15 UTC (rev 6724) @@ -31,6 +31,7 @@ pzmap zero Time Domain Analysis + covar gensig impulse initial Added: trunk/octave-forge/extra/control-oo/inst/covar.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/covar.m (rev 0) +++ trunk/octave-forge/extra/control-oo/inst/covar.m 2010-01-09 16:14:15 UTC (rev 6724) @@ -0,0 +1,75 @@ +## Copyright (C) 2010 Lukas F. Reichlin +## +## This file is part of LTI Syncope. +## +## LTI Syncope 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. +## +## LTI Syncope 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, see <http://www.gnu.org/licenses/>. + +## -*- texinfo -*- +## @deftypefn{Function File} {[@var{p}, @var{q}] =} covar (@var{sys}, @var{w}) +## Return the (steady-state) output covariance p as well as the state +## covariance q for a lti model sys driven by the Gaussian white noise +## inputs w. +## @end deftypefn + +## Author: Lukas Reichlin <luk...@gm...> +## Created: January 2010 +## Version: 0.1 + +function [p, q] = covar (sys, w) + + if (nargin != 2) + print_usage (); + endif + + if (! isa (sys, "lti")) + error ("covar: first argument must be a lti model"); + endif + + if (! isstable (sys)) + error ("covar: system must be stable"); + endif + + [a, b, c, d] = ssdata (sys); + + if (isct (sys)) + if (! all (all (d == 0))) + error ("covar: system is not strictly proper"); + endif + + q = lyap (a, b*w*b'); + p = c*q*c'; + else + q = dlyap (a, b*w*b'); + p = c*q*c' + d*w*d'; + endif + +endfunction + +## continuous-time +%!shared p, q, p_exp, q_exp +%! sys = ss (-1, 1, 1, 0); +%! [p, q] = covar (sys, 5); +%! p_exp = 2.5000; +%! q_exp = 2.5000; +%!assert (p, p_exp, 1e-4); +%!assert (q, q_exp, 1e-4); + +## discrete-time +%!shared p, q, p_exp, q_exp +%! sys = ss ([-0.2, -0.5; 1, 0], [2; 0], [1, 0.5], [0], 0.1); +%! [p, q] = covar (sys, 5); +%! p_exp = 30.3167; +%! q_exp = [27.1493, -3.6199; -3.6199, 27.1493]; +%!assert (p, p_exp, 1e-4); +%!assert (q, q_exp, 1e-4); \ No newline at end of file This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <par...@us...> - 2010-01-10 16:19:07
|
Revision: 6730 http://octave.svn.sourceforge.net/octave/?rev=6730&view=rev Author: paramaniac Date: 2010-01-10 16:18:59 +0000 (Sun, 10 Jan 2010) Log Message: ----------- control-oo: add support for Sylvester equations Modified Paths: -------------- trunk/octave-forge/extra/control-oo/inst/dlyap.m trunk/octave-forge/extra/control-oo/inst/lyap.m trunk/octave-forge/extra/control-oo/src/Makefile Added Paths: ----------- trunk/octave-forge/extra/control-oo/src/SB04MD.f trunk/octave-forge/extra/control-oo/src/SB04MR.f trunk/octave-forge/extra/control-oo/src/SB04MU.f trunk/octave-forge/extra/control-oo/src/SB04MW.f trunk/octave-forge/extra/control-oo/src/SB04MY.f trunk/octave-forge/extra/control-oo/src/SB04QD.f trunk/octave-forge/extra/control-oo/src/SB04QR.f trunk/octave-forge/extra/control-oo/src/SB04QU.f trunk/octave-forge/extra/control-oo/src/SB04QY.f trunk/octave-forge/extra/control-oo/src/slsb04md.cc trunk/octave-forge/extra/control-oo/src/slsb04qd.cc Modified: trunk/octave-forge/extra/control-oo/inst/dlyap.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/dlyap.m 2010-01-10 15:16:53 UTC (rev 6729) +++ trunk/octave-forge/extra/control-oo/inst/dlyap.m 2010-01-10 16:18:59 UTC (rev 6730) @@ -17,10 +17,15 @@ ## -*- texinfo -*- ## @deftypefn{Function File} {@var{x} =} dlyap (@var{a}, @var{b}) -## +## @deftypefnx{Function File} {@var{x} =} dlyap (@var{a}, @var{b}, @var{c}) +## Solve discrete-time Lyapunov or Sylvester equations. +## Uses SLICOT SB03MD and SB04QD by courtesy of NICONET e.V. +## <http://www.slicot.org> ## @example ## @group +## AXA' - X + B = 0 (Lyapunov Equation) ## +## AXB' - X + C = 0 (Sylvester Equation) ## @end group ## @end example ## @end deftypefn @@ -29,29 +34,51 @@ ## Created: January 2010 ## Version: 0.1 -function x = dlyap (a, b) +function x = dlyap (a, b, c) - if (nargin != 2) - print_usage (); - endif + if (nargin == 2) - na = issquare (a); - nb = issquare (b); + na = issquare (a); + nb = issquare (b); - if (! na) - error ("lyap: a must be square"); - endif + if (! na) + error ("lyap: a must be square"); + endif - if (! nb) - error ("lyap: b must be square") - endif + if (! nb) + error ("lyap: b must be square") + endif - if (na != nb) - error ("lyap: a and b must be of identical size"); - endif + if (na != nb) + error ("lyap: a and b must be of identical size"); + endif - x = slsb03md (a, -b, true); # AXA' - X = -B + x = slsb03md (a, -b, true); # AXA' - X = -B + + elseif (nargin == 3) + + n = issquare (a); + m = issquare (b); + [crows, ccols] = size (c); + + if (! n) + error ("dlyap: a must be square"); + endif + + if (! m) + error ("dlyap: b must be square"); + endif + + if (crows != n || ccols != m) + error ("dlyap: c must be a (%dx%d) matrix", n, m); + endif + + x = slsb04qd (-a, b, c); # AXB' - X = -C + else + print_usage (); + endif + endfunction @@ -71,4 +98,26 @@ %! 1.0000 3.0000 0.0000 %! 1.0000 0.0000 4.0000]; %! +%!assert (X, X_exp, 1e-4); + +## Sylvester +%!shared X, X_exp +%! A = [1.0 2.0 3.0 +%! 6.0 7.0 8.0 +%! 9.0 2.0 3.0]; +%! +%! B = [7.0 2.0 3.0 +%! 2.0 1.0 2.0 +%! 3.0 4.0 1.0]; +%! +%! C = [271.0 135.0 147.0 +%! 923.0 494.0 482.0 +%! 578.0 383.0 287.0]; +%! +%! X = dlyap (-A, B, C); +%! +%! X_exp = [2.0000 3.0000 6.0000 +%! 4.0000 7.0000 1.0000 +%! 5.0000 3.0000 2.0000]; +%! %!assert (X, X_exp, 1e-4); \ No newline at end of file Modified: trunk/octave-forge/extra/control-oo/inst/lyap.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/lyap.m 2010-01-10 15:16:53 UTC (rev 6729) +++ trunk/octave-forge/extra/control-oo/inst/lyap.m 2010-01-10 16:18:59 UTC (rev 6730) @@ -16,11 +16,16 @@ ## along with this program. If not, see <http://www.gnu.org/licenses/>. ## -*- texinfo -*- -## @deftypefn{Function File} {@var{x} =} lyap (@var{a}, @var{q}) -## +## @deftypefn{Function File} {@var{x} =} lyap (@var{a}, @var{b}) +## @deftypefnx{Function File} {@var{x} =} lyap (@var{a}, @var{b}, @var{c}) +## Solve continuous-time Lyapunov or Sylvester equations. +## Uses SLICOT SB03MD and SB04MD by courtesy of NICONET e.V. +## <http://www.slicot.org> ## @example ## @group +## AX + XA' + B = 0 (Lyapunov Equation) ## +## AX + XB + C = 0 (Sylvester Equation) ## @end group ## @end example ## @end deftypefn @@ -29,36 +34,80 @@ ## Created: January 2010 ## Version: 0.1 -function x = lyap (a, q) +function x = lyap (a, b, c) - if (nargin != 2) - print_usage (); - endif + if (nargin == 2) - na = issquare (a); - nq = issquare (q); + na = issquare (a); + nb = issquare (b); - if (! na) - error ("lyap: a must be square"); - endif + if (! na) + error ("lyap: a must be square"); + endif - if (! nq) - error ("lyap: q must be square") - endif + if (! nb) + error ("lyap: b must be square") + endif - if (na != nq) - error ("lyap: a and q must be of identical size"); + if (na != nb) + error ("lyap: a and b must be of identical size"); + endif + + x = slsb03md (a, -b, false); # AX + XA' = -B + + elseif (nargin == 3) + + n = issquare (a); + m = issquare (b); + [crows, ccols] = size (c); + + if (! n) + error ("lyap: a must be square"); + endif + + if (! m) + error ("lyap: b must be square"); + endif + + if (crows != n || ccols != m) + error ("lyap: c must be a (%dx%d) matrix", n, m); + endif + + x = slsb04md (a, b, -c); # AX + XB = -C + + else + print_usage (); endif - - x = slsb03md (a, -q, false); endfunction +## Lyapunov %!shared X, X_exp %! A = [1, 2; -3, -4]; %! Q = [3, 1; 1, 1]; %! X = lyap (A, Q); %! X_exp = [ 6.1667, -3.8333; %! -3.8333, 3.0000]; -%!assert (X, X_exp, 1e-4); \ No newline at end of file +%!assert (X, X_exp, 1e-4); + +## Sylvester +%!shared X, X_exp +%! A = [2.0 1.0 3.0 +%! 0.0 2.0 1.0 +%! 6.0 1.0 2.0]; +%! +%! B = [2.0 1.0 +%! 1.0 6.0]; +%! +%! C = [2.0 1.0 +%! 1.0 4.0 +%! 0.0 5.0]; +%! +%! X = lyap (A, B, -C); +%! +%! X_exp = [-2.7685 0.5498 +%! -1.0531 0.6865 +%! 4.5257 -0.4389]; +%! +%!assert (X, X_exp, 1e-4); Modified: trunk/octave-forge/extra/control-oo/src/Makefile =================================================================== --- trunk/octave-forge/extra/control-oo/src/Makefile 2010-01-10 15:16:53 UTC (rev 6729) +++ trunk/octave-forge/extra/control-oo/src/Makefile 2010-01-10 16:18:59 UTC (rev 6730) @@ -1,5 +1,6 @@ all: slab08nd.oct slab13dd.oct slsb10hd.oct slsb10ed.oct slab13bd.oct \ - slsb01bd.oct slsb10fd.oct slsb10dd.oct slsb03md.oct + slsb01bd.oct slsb10fd.oct slsb10dd.oct slsb03md.oct slsb04md.oct \ + slsb04qd.oct # transmission zeros of state-space models slab08nd.oct: slab08nd.cc @@ -74,5 +75,15 @@ SB03MD.f select.f SB03MX.f SB03MY.f MB01RD.f \ SB03MV.f SB03MW.f SB04PX.f +# Sylvester equations - continuous-time +slsb04md.oct: slsb04md.cc + mkoctfile slsb04md.cc \ + SB04MD.f SB04MU.f SB04MY.f SB04MR.f SB04MW.f + +# Sylvester equations - discrete-time +slsb04qd.oct: slsb04qd.cc + mkoctfile slsb04qd.cc \ + SB04QD.f SB04QU.f SB04QY.f SB04MW.f SB04QR.f + clean: rm *.o core octave-core *.oct *~ Added: trunk/octave-forge/extra/control-oo/src/SB04MD.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/SB04MD.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/SB04MD.f 2010-01-10 16:18:59 UTC (rev 6730) @@ -0,0 +1,347 @@ + SUBROUTINE SB04MD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To solve for X the continuous-time Sylvester equation +C +C AX + XB = C +C +C where A, B, C and X are general N-by-N, M-by-M, N-by-M and +C N-by-M matrices respectively. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the coefficient matrix A of the equation. +C On exit, the leading N-by-N upper Hessenberg part of this +C array contains the matrix H, and the remainder of the +C leading N-by-N part, together with the elements 2,3,...,N +C of array DWORK, contain the orthogonal transformation +C matrix U (stored in factored form). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading M-by-M part of this array must +C contain the coefficient matrix B of the equation. +C On exit, the leading M-by-M part of this array contains +C the quasi-triangular Schur factor S of the matrix B'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading N-by-M part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading N-by-M part of this array contains +C the solution matrix X of the problem. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,M) +C The leading M-by-M part of this array contains the +C orthogonal matrix Z used to transform B' to real upper +C Schur form. +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= MAX(1,M). +C +C Workspace +C +C IWORK INTEGER array, dimension (4*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and DWORK(2), DWORK(3),..., DWORK(N) contain +C the scalar factors of the elementary reflectors used to +C reduce A to upper Hessenberg form, as returned by LAPACK +C Library routine DGEHRD. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = MAX(1, 2*N*N + 8*N, 5*M, N + M). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, 1 <= i <= M, the QR algorithm failed to +C compute all the eigenvalues (see LAPACK Library +C routine DGEES); +C > M: if a singular matrix was encountered whilst solving +C for the (INFO-M)-th column of matrix X. +C +C METHOD +C +C The matrix A is transformed to upper Hessenberg form H = U'AU by +C the orthogonal transformation matrix U; matrix B' is transformed +C to real upper Schur form S = Z'B'Z using the orthogonal +C transformation matrix Z. The matrix C is also multiplied by the +C transformations, F = U'CZ, and the solution matrix Y of the +C transformed system +C +C HY + YS' = F +C +C is computed by back substitution. Finally, the matrix Y is then +C multiplied by the orthogonal transformation matrices, X = UYZ', in +C order to obtain the solution matrix X to the original problem. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C 3 3 2 2 +C The algorithm requires about (5/3) N + 10 M + 5 N M + 2.5 M N +C operations and is backward stable. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04AD by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000, Aug. 2000. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDWORK, LDZ, M, N +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER I, IEIG, IFAIL, IHI, ILO, IND, ITAU, JWORK, + $ SDIM, WRKOPT +C .. Local Scalars .. + LOGICAL SELECT +C .. Local Arrays .. + LOGICAL BWORK(1) +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEHRD, DGEMM, DGEMV, DLACPY, + $ DORMHR, DSWAP, SB04MU, SB04MY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDZ.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDWORK.LT.MAX( 1, 2*N*N + 8*N, 5*M, N + M ) ) THEN + INFO = -13 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB04MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + ILO = 1 + IHI = N + WRKOPT = 1 +C +C Step 1 : Reduce A to upper Hessenberg and B' to quasi-upper +C triangular. That is, H = U' * A * U (store U in factored +C form) and S = Z' * B' * Z (save Z). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + DO 20 I = 2, M + CALL DSWAP( I-1, B(1,I), 1, B(I,1), LDB ) + 20 CONTINUE +C +C Workspace: need 5*M; +C prefer larger. +C + IEIG = M + 1 + JWORK = IEIG + M + CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, B, LDB, + $ SDIM, DWORK, DWORK(IEIG), Z, LDZ, DWORK(JWORK), + $ LDWORK-JWORK+1, BWORK, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Workspace: need 2*N; +C prefer N + N*NB. +C + ITAU = 2 + JWORK = ITAU + N - 1 + CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Step 2 : Form F = ( U' * C ) * Z. Use BLAS 3, if enough space. +C +C Workspace: need N + M; +C prefer N + M*NB. +C + CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, A, LDA, + $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, + $ IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + IF ( LDWORK.GE.JWORK - 1 + N*M ) THEN + CALL DGEMM( 'No transpose', 'No transpose', N, M, M, ONE, C, + $ LDC, Z, LDZ, ZERO, DWORK(JWORK), N ) + CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) + WRKOPT = MAX( WRKOPT, JWORK - 1 + N*M ) + ELSE +C + DO 40 I = 1, N + CALL DGEMV( 'Transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, + $ ZERO, DWORK(JWORK), 1 ) + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + 40 CONTINUE +C + END IF +C + IND = M + 60 CONTINUE + IF ( IND.GT.1 ) THEN +C +C Step 3 : Solve H * Y + Y * S' = F for Y. +C + IF ( B(IND,IND-1).EQ.ZERO ) THEN +C +C Solve a special linear algebraic system of order N. +C Workspace: N*(N+1)/2 + 3*N. +C + CALL SB04MY( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + WRKOPT = MAX( WRKOPT, JWORK + N*( N + 1 )/2 + 2*N - 1 ) + IND = IND - 1 + ELSE +C +C Solve a special linear algebraic system of order 2*N. +C Workspace: 2*N*N + 8*N; +C + CALL SB04MU( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + WRKOPT = MAX( WRKOPT, JWORK + 2*N*N + 7*N - 1 ) + IND = IND - 2 + END IF + GO TO 60 + ELSE IF ( IND.EQ.1 ) THEN +C +C Solve a special linear algebraic system of order N. +C Workspace: N*(N+1)/2 + 3*N; +C + CALL SB04MY( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + WRKOPT = MAX( WRKOPT, JWORK + N*( N + 1 )/2 + 2*N - 1 ) + END IF +C +C Step 4 : Form C = ( U * Y ) * Z'. Use BLAS 3, if enough space. +C +C Workspace: need N + M; +C prefer N + M*NB. +C + CALL DORMHR( 'Left', 'No transpose', N, M, ILO, IHI, A, LDA, + $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, + $ IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + IF ( LDWORK.GE.JWORK - 1 + N*M ) THEN + CALL DGEMM( 'No transpose', 'Transpose', N, M, M, ONE, C, LDC, + $ Z, LDZ, ZERO, DWORK(JWORK), N ) + CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) + ELSE +C + DO 80 I = 1, N + CALL DGEMV( 'No transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, + $ ZERO, DWORK(JWORK), 1 ) + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + 80 CONTINUE + END IF +C + RETURN +C *** Last line of SB04MD *** + END Added: trunk/octave-forge/extra/control-oo/src/SB04MR.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/SB04MR.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/SB04MR.f 2010-01-10 16:18:59 UTC (rev 6730) @@ -0,0 +1,222 @@ + SUBROUTINE SB04MR( M, D, IPR, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To solve a linear algebraic system of order M whose coefficient +C matrix has zeros below the second subdiagonal. The matrix is +C stored compactly, row-wise. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the system. M >= 0. +C Note that parameter M should have twice the value in the +C original problem (see SLICOT Library routine SB04MU). +C +C D (input/output) DOUBLE PRECISION array, dimension +C (M*(M+1)/2+3*M) +C On entry, the first M*(M+1)/2 + 2*M elements of this array +C must contain the coefficient matrix, stored compactly, +C row-wise, and the next M elements must contain the right +C hand side of the linear system, as set by SLICOT Library +C routine SB04MU. +C On exit, the content of this array is updated, the last M +C elements containing the solution with components +C interchanged (see IPR). +C +C IPR (output) INTEGER array, dimension (2*M) +C The leading M elements contain information about the +C row interchanges performed for solving the system. +C Specifically, the i-th component of the solution is +C specified by IPR(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if a singular matrix was encountered. +C +C METHOD +C +C Gaussian elimination with partial pivoting is used. The rows of +C the matrix are not actually permuted, only their indices are +C interchanged in array IPR. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB04AR by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, M +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION D(*) +C .. Local Scalars .. + INTEGER I, I1, I2, IPRM, IPRM1, J, K, L, M1, MPI, MPI1, + $ MPI2 + DOUBLE PRECISION D1, D2, D3, DMAX +C .. External Subroutines .. + EXTERNAL DAXPY +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + INFO = 0 + I2 = ( M*( M + 5 ) )/2 + MPI = M + IPRM = I2 + M1 = M + I1 = 1 +C + DO 20 I = 1, M + MPI = MPI + 1 + IPRM = IPRM + 1 + IPR(MPI) = I1 + IPR(I) = IPRM + I1 = I1 + M1 + IF ( I.GE.3 ) M1 = M1 - 1 + 20 CONTINUE +C + M1 = M - 1 + MPI1 = M + 1 +C +C Reduce to upper triangular form. +C + DO 80 I = 1, M1 + MPI = MPI1 + MPI1 = MPI1 + 1 + IPRM = IPR(MPI) + D1 = D(IPRM) + I1 = 2 + IF ( I.EQ.M1 ) I1 = 1 + MPI2 = MPI + I1 + L = 0 + DMAX = ABS( D1 ) +C + DO 40 J = MPI1, MPI2 + D2 = D(IPR(J)) + D3 = ABS( D2 ) + IF ( D3.GT.DMAX ) THEN + DMAX = D3 + D1 = D2 + L = J - MPI + END IF + 40 CONTINUE +C +C Check singularity. +C + IF ( DMAX.EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C + IF ( L.GT.0 ) THEN +C +C Permute the row indices. +C + K = IPRM + J = MPI + L + IPRM = IPR(J) + IPR(J) = K + IPR(MPI) = IPRM + K = IPR(I) + I2 = I + L + IPR(I) = IPR(I2) + IPR(I2) = K + END IF + IPRM = IPRM + 1 +C +C Annihilate the subdiagonal elements of the matrix. +C + I2 = I + D3 = D(IPR(I)) +C + DO 60 J = MPI1, MPI2 + I2 = I2 + 1 + IPRM1 = IPR(J) + DMAX = -D(IPRM1)/D1 + D(IPR(I2)) = D(IPR(I2)) + DMAX*D3 + CALL DAXPY( M-I, DMAX, D(IPRM), 1, D(IPRM1+1), 1 ) + 60 CONTINUE +C + IPR(MPI1) = IPR(MPI1) + 1 + IF ( I.NE.M1 ) IPR(MPI2) = IPR(MPI2) + 1 + 80 CONTINUE +C + MPI = M + M + IPRM = IPR(MPI) +C +C Check singularity. +C + IF ( D(IPRM).EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C +C Back substitution. +C + D(IPR(M)) = D(IPR(M))/D(IPRM) +C + DO 120 I = M1, 1, -1 + MPI = MPI - 1 + IPRM = IPR(MPI) + IPRM1 = IPRM + DMAX = ZERO +C + DO 100 K = I+1, M + IPRM1 = IPRM1 + 1 + DMAX = DMAX + D(IPR(K))*D(IPRM1) + 100 CONTINUE +C + D(IPR(I)) = ( D(IPR(I)) - DMAX )/D(IPRM) + 120 CONTINUE +C + RETURN +C *** Last line of SB04MR *** + END Added: trunk/octave-forge/extra/control-oo/src/SB04MU.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/SB04MU.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/SB04MU.f 2010-01-10 16:18:59 UTC (rev 6730) @@ -0,0 +1,190 @@ + SUBROUTINE SB04MU( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To construct and solve a linear algebraic system of order 2*M +C whose coefficient matrix has zeros below the second subdiagonal. +C Such systems appear when solving continuous-time Sylvester +C equations using the Hessenberg-Schur method. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix B. N >= 0. +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C IND (input) INTEGER +C IND and IND - 1 specify the indices of the columns in C +C to be computed. IND > 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain an +C upper Hessenberg matrix. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain a +C matrix in real Schur form. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading M-by-N part of this array contains +C the matrix C with columns IND-1 and IND updated. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C Workspace +C +C D DOUBLE PRECISION array, dimension (2*M*M+7*M) +C +C IPR INTEGER array, dimension (4*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C > 0: if INFO = IND, a singular matrix was encountered. +C +C METHOD +C +C A special linear algebraic system of order 2*M, whose coefficient +C matrix has zeros below the second subdiagonal is constructed and +C solved. The coefficient matrix is stored compactly, row-wise. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB04AU by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, IND, LDA, LDB, LDC, M, N +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) +C .. Local Scalars .. + INTEGER I, I2, IND1, J, K, K1, K2, M2 + DOUBLE PRECISION TEMP +C .. External Subroutines .. + EXTERNAL DAXPY, SB04MR +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + IND1 = IND - 1 +C + DO 20 I = IND + 1, N + CALL DAXPY( M, -B(IND1,I), C(1,I), 1, C(1,IND1), 1 ) + CALL DAXPY( M, -B(IND,I), C(1,I), 1, C(1,IND), 1 ) + 20 CONTINUE +C +C Construct the linear algebraic system of order 2*M. +C + K1 = -1 + M2 = 2*M + I2 = M*(M2 + 5) + K = M2 +C + DO 60 I = 1, M +C + DO 40 J = MAX( 1, I - 1 ), M + K1 = K1 + 2 + K2 = K1 + K + TEMP = A(I,J) + IF ( I.NE.J ) THEN + D(K1) = TEMP + D(K1+1) = ZERO + IF ( J.GT.I ) D(K2) = ZERO + D(K2+1) = TEMP + ELSE + D(K1) = TEMP + B(IND1,IND1) + D(K1+1) = B(IND1,IND) + D(K2) = B(IND,IND1) + D(K2+1) = TEMP + B(IND,IND) + END IF + 40 CONTINUE +C + K1 = K2 + K = K - MIN( 2, I ) +C +C Store the right hand side. +C + I2 = I2 + 2 + D(I2) = C(I,IND) + D(I2-1) = C(I,IND1) + 60 CONTINUE +C +C Solve the linear algebraic system and store the solution in C. +C + CALL SB04MR( M2, D, IPR, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = IND + ELSE + I2 = 0 +C + DO 80 I = 1, M + I2 = I2 + 2 + C(I,IND1) = D(IPR(I2-1)) + C(I,IND) = D(IPR(I2)) + 80 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB04MU *** + END Added: trunk/octave-forge/extra/control-oo/src/SB04MW.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/SB04MW.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/SB04MW.f 2010-01-10 16:18:59 UTC (rev 6730) @@ -0,0 +1,194 @@ + SUBROUTINE SB04MW( M, D, IPR, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To solve a linear algebraic system of order M whose coefficient +C matrix is in upper Hessenberg form, stored compactly, row-wise. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the system. M >= 0. +C +C D (input/output) DOUBLE PRECISION array, dimension +C (M*(M+1)/2+2*M) +C On entry, the first M*(M+1)/2 + M elements of this array +C must contain an upper Hessenberg matrix, stored compactly, +C row-wise, and the next M elements must contain the right +C hand side of the linear system, as set by SLICOT Library +C routine SB04MY. +C On exit, the content of this array is updated, the last M +C elements containing the solution with components +C interchanged (see IPR). +C +C IPR (output) INTEGER array, dimension (2*M) +C The leading M elements contain information about the +C row interchanges performed for solving the system. +C Specifically, the i-th component of the solution is +C specified by IPR(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if a singular matrix was encountered. +C +C METHOD +C +C Gaussian elimination with partial pivoting is used. The rows of +C the matrix are not actually permuted, only their indices are +C interchanged in array IPR. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB04AW by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, M +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION D(*) +C .. Local Scalars .. + INTEGER I, I1, IPRM, IPRM1, K, M1, M2, MPI + DOUBLE PRECISION D1, D2, MULT +C .. External Subroutines .. + EXTERNAL DAXPY +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + INFO = 0 + M1 = ( M*( M + 3 ) )/2 + M2 = M + M + MPI = M + IPRM = M1 + M1 = M + I1 = 1 +C + DO 20 I = 1, M + MPI = MPI + 1 + IPRM = IPRM + 1 + IPR(MPI) = I1 + IPR(I) = IPRM + I1 = I1 + M1 + IF ( I.GT.1 ) M1 = M1 - 1 + 20 CONTINUE +C + M1 = M - 1 + MPI = M +C +C Reduce to upper triangular form. +C + DO 40 I = 1, M1 + I1 = I + 1 + MPI = MPI + 1 + IPRM = IPR(MPI) + IPRM1 = IPR(MPI+1) + D1 = D(IPRM) + D2 = D(IPRM1) + IF ( ABS( D1 ).LE.ABS( D2 ) ) THEN +C +C Permute the row indices. +C + K = IPRM + IPR(MPI) = IPRM1 + IPRM = IPRM1 + IPRM1 = K + K = IPR(I) + IPR(I) = IPR(I1) + IPR(I1) = K + D1 = D2 + END IF +C +C Check singularity. +C + IF ( D1.EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C + MULT = -D(IPRM1)/D1 + IPRM1 = IPRM1 + 1 + IPR(MPI+1) = IPRM1 +C +C Annihilate the subdiagonal elements of the matrix. +C + D(IPR(I1)) = D(IPR(I1)) + MULT*D(IPR(I)) + CALL DAXPY( M-I, MULT, D(IPRM+1), 1, D(IPRM1), 1 ) + 40 CONTINUE +C +C Check singularity. +C + IF ( D(IPR(M2)).EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C +C Back substitution. +C + D(IPR(M)) = D(IPR(M))/D(IPR(M2)) + MPI = M2 +C + DO 80 I = M1, 1, -1 + MPI = MPI - 1 + IPRM = IPR(MPI) + IPRM1 = IPRM + MULT = ZERO +C + DO 60 I1 = I + 1, M + IPRM1 = IPRM1 + 1 + MULT = MULT + D(IPR(I1))*D(IPRM1) + 60 CONTINUE +C + D(IPR(I)) = ( D(IPR(I)) - MULT )/D(IPRM) + 80 CONTINUE +C + RETURN +C *** Last line of SB04MW *** + END Added: trunk/octave-forge/extra/control-oo/src/SB04MY.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/SB04MY.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/SB04MY.f 2010-01-10 16:18:59 UTC (rev 6730) @@ -0,0 +1,168 @@ + SUBROUTINE SB04MY( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To construct and solve a linear algebraic system of order M whose +C coefficient matrix is in upper Hessenberg form. Such systems +C appear when solving Sylvester equations using the Hessenberg-Schur +C method. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix B. N >= 0. +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C IND (input) INTEGER +C The index of the column in C to be computed. IND >= 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain an +C upper Hessenberg matrix. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain a +C matrix in real Schur form. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading M-by-N part of this array contains +C the matrix C with column IND updated. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C Workspace +C +C D DOUBLE PRECISION array, dimension (M*(M+1)/2+2*M) +C +C IPR INTEGER array, dimension (2*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C > 0: if INFO = IND, a singular matrix was encountered. +C +C METHOD +C +C A special linear algebraic system of order M, with coefficient +C matrix in upper Hessenberg form is constructed and solved. The +C coefficient matrix is stored compactly, row-wise. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB04AY by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INFO, IND, LDA, LDB, LDC, M, N +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) +C .. Local Scalars .. + INTEGER I, I2, J, K, K1, K2, M1 +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, SB04MW +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + DO 20 I = IND + 1, N + CALL DAXPY( M, -B(IND,I), C(1,I), 1, C(1,IND), 1 ) + 20 CONTINUE +C + M1 = M + 1 + I2 = ( M*M1 )/2 + M1 + K2 = 1 + K = M +C +C Construct the linear algebraic system of order M. +C + DO 40 I = 1, M + J = M1 - K + CALL DCOPY ( K, A(I,J), LDA, D(K2), 1 ) + K1 = K2 + K2 = K2 + K + IF ( I.GT.1 ) THEN + K1 = K1 + 1 + K = K - 1 + END IF + D(K1) = D(K1) + B(IND,IND) +C +C Store the right hand side. +C + D(I2) = C(I,IND) + I2 = I2 + 1 + 40 CONTINUE +C +C Solve the linear algebraic system and store the solution in C. +C + CALL SB04MW( M, D, IPR, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = IND + ELSE +C + DO 60 I = 1, M + C(I,IND) = D(IPR(I)) + 60 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB04MY *** + END Added: trunk/octave-forge/extra/control-oo/src/SB04QD.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/SB04QD.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/SB04QD.f 2010-01-10 16:18:59 UTC (rev 6730) @@ -0,0 +1,376 @@ + SUBROUTINE SB04QD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To solve for X the discrete-time Sylvester equation +C +C X + AXB = C, +C +C where A, B, C and X are general N-by-N, M-by-M, N-by-M and +C N-by-M matrices respectively. A Hessenberg-Schur method, which +C reduces A to upper Hessenberg form, H = U'AU, and B' to real +C Schur form, S = Z'B'Z (with U, Z orthogonal matrices), is used. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the coefficient matrix A of the equation. +C On exit, the leading N-by-N upper Hessenberg part of this +C array contains the matrix H, and the remainder of the +C leading N-by-N part, together with the elements 2,3,...,N +C of array DWORK, contain the orthogonal transformation +C matrix U (stored in factored form). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading M-by-M part of this array must +C contain the coefficient matrix B of the equation. +C On exit, the leading M-by-M part of this array contains +C the quasi-triangular Schur factor S of the matrix B'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading N-by-M part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading N-by-M part of this array contains +C the solution matrix X of the problem. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,M) +C The leading M-by-M part of this array contains the +C orthogonal matrix Z used to transform B' to real upper +C Schur form. +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= MAX(1,M). +C +C Workspace +C +C IWORK INTEGER array, dimension (4*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and DWORK(2), DWORK(3),..., DWORK(N) contain +C the scalar factors of the elementary reflectors used to +C reduce A to upper Hessenberg form, as returned by LAPACK +C Library routine DGEHRD. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = MAX(1, 2*N*N + 9*N, 5*M, N + M). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, 1 <= i <= M, the QR algorithm failed to +C compute all the eigenvalues of B (see LAPACK Library +C routine DGEES); +C > M: if a singular matrix was encountered whilst solving +C for the (INFO-M)-th column of matrix X. +C +C METHOD +C +C The matrix A is transformed to upper Hessenberg form H = U'AU by +C the orthogonal transformation matrix U; matrix B' is transformed +C to real upper Schur form S = Z'B'Z using the orthogonal +C transformation matrix Z. The matrix C is also multiplied by the +C transformations, F = U'CZ, and the solution matrix Y of the +C transformed system +C +C Y + HYS' = F +C +C is computed by back substitution. Finally, the matrix Y is then +C multiplied by the orthogonal transformation matrices, X = UYZ', in +C order to obtain the solution matrix X to the original problem. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C [2] Sima, V. +C Algorithms for Linear-quadratic Optimization. +C Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C 3 3 2 2 +C The algorithm requires about (5/3) N + 10 M + 5 N M + 2.5 M N +C operations and is backward stable. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000, Aug. 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2000. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDWORK, LDZ, M, N +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER BL, CHUNK, I, IEIG, IFAIL, IHI, ILO, IND, ITAU, + $ JWORK, SDIM, WRKOPT +C .. Local Scalars .. + LOGICAL BLAS3, BLOCK +C .. Local Arrays .. + LOGICAL BWORK(1) +C .. External Functions .. + LOGICAL SELECT +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEHRD, DGEMM, DGEMV, DLACPY, + $ DORMHR, DSWAP, SB04QU, SB04QY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDZ.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDWORK.LT.MAX( 1, 2*N*N + 9*N, 5*M, N + M ) ) THEN + INFO = -13 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB04QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + ILO = 1 + IHI = N + WRKOPT = 2*N*N + 9*N +C +C Step 1 : Reduce A to upper Hessenberg and B' to quasi-upper +C triangular. That is, H = U' * A * U (store U in factored +C form) and S = Z' * B' * Z (save Z). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + DO 20 I = 2, M + CALL DSWAP( I-1, B(1,I), 1, B(I,1), LDB ) + 20 CONTINUE +C +C Workspace: need 5*M; +C prefer larger. +C + IEIG = M + 1 + JWORK = IEIG + M + CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, B, LDB, + $ SDIM, DWORK, DWORK(IEIG), Z, LDZ, DWORK(JWORK), + $ LDWORK-JWORK+1, BWORK, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Workspace: need 2*N; +C prefer N + N*NB. +C + ITAU = 2 + JWORK = ITAU + N - 1 + CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Step 2 : Form F = ( U' * C ) * Z. Use BLAS 3, if enough space. +C +C Workspace: need N + M; +C prefer N + M*NB. +C + CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, A, LDA, + $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, + $ IFAIL ) + WRKOPT = MAX( WRKOPT, MAX( INT( DWORK(JWORK) ), N*M )+JWORK-1 ) +C + CHUNK = ( LDWORK - JWORK + 1 ) / M + BLOCK = MIN( CHUNK, N ).GT.1 + BLAS3 = CHUNK.GE.N .AND. BLOCK +C + IF ( BLAS3 ) THEN + CALL DGEMM( 'No transpose', 'No transpose', N, M, M, ONE, C, + $ LDC, Z, LDZ, ZERO, DWORK(JWORK), N ) + CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) +C + ELSE IF ( BLOCK ) THEN +C +C Use as many rows of C as possible. +C + DO 40 I = 1, N, CHUNK + BL = MIN( N-I+1, CHUNK ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, M, M, ONE, + $ C(I,1), LDC, Z, LDZ, ZERO, DWORK(JWORK), BL ) + CALL DLACPY( 'Full', BL, M, DWORK(JWORK), BL, C(I,1), LDC ) + 40 CONTINUE +C + ELSE +C + DO 60 I = 1, N + CALL DGEMV( 'Transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, + $ ZERO, DWORK(JWORK), 1 ) + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + 60 CONTINUE +C + END IF +C +C Step 3 : Solve Y + H * Y * S' = F for Y. +C + IND = M + 80 CONTINUE +C + IF ( IND.GT.1 ) THEN + IF ( B(IND,IND-1).EQ.ZERO ) THEN +C +C Solve a special linear algebraic system of order N. +C Workspace: N*(N+1)/2 + 3*N. +C + CALL SB04QY( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + IND = IND - 1 + ELSE +C +C Solve a special linear algebraic system of order 2*N. +C Workspace: 2*N*N + 9*N; +C + CALL SB04QU( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + IND = IND - 2 + END IF + GO TO 80 + ELSE IF ( IND.EQ.1 ) THEN +C +C Solve a special linear algebraic system of order N. +C Workspace: N*(N+1)/2 + 3*N; +C + CALL SB04QY( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + END IF +C +C Step 4 : Form C = ( U * Y ) * Z'. Use BLAS 3, if enough space. +C +C Workspace: need N + M; +C prefer N + M*NB. +C + CALL DORMHR( 'Left', 'No transpose', N, M, ILO, IHI, A, LDA, + $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, + $ IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + IF ( BLAS3 ) THEN + CALL DGEMM( 'No transpose', 'Transpose', N, M, M, ONE, C, LDC, + $ Z, LDZ, ZERO, DWORK(JWORK), N ) + CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) +C + ELSE IF ( BLOCK ) THEN +C +C Use as many rows of C as possible. +C + DO 100 I = 1, N, CHUNK + BL = MIN( N-I+1, CHUNK ) + CALL DGEMM( 'NoTranspose', 'Transpose', BL, M, M, ONE, + $ C(I,1), LDC, Z, LDZ, ZERO, DWORK(JWORK), BL ) + CALL DLACPY( 'Full', BL, M, DWORK(JWORK), BL, C(I,1), LDC ) + 100 CONTINUE +C + ELSE +C + DO 120 I = 1, N + CALL DGEMV( 'No transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, + $ ZERO, DWORK(JWORK), 1 ) + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + 120 CONTINUE + END IF +C + RETURN +C *** Last line of SB04QD *** + END Added: trunk/octave-forge/extra/control-oo/src/SB04QR.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/SB04QR.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/SB04QR.f 2010-01-10 16:18:59 UTC (rev 6730) @@ -0,0 +1,224 @@ + SUBROUTINE SB04QR( M, D, IPR, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To solve a linear algebraic system of order M whose coefficient +C matrix has zeros below the third subdiagonal and zero elements on +C the third subdiagonal with even column indices. The matrix is +C stored compactly, row-wise. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the system. M >= 0, M even. +C Note that parameter M should have twice the value in the +C original problem (see SLICOT Library routine SB04QU). +C +C D (input/output) DOUBLE PRECISION array, dimension +C (M*M/2+4*M) +C On entry, the first M*M/2 + 3*M elements of this array +C must contain the coefficient matrix, stored compactly, +C row-wise, and the next M elements must contain the right +C hand side of the linear system, as set by SLICOT Library +C routine SB04QU. +C On exit, the content of this array is updated, the last M +C elements containing the solution with components +C interchanged (see IPR). +C +C IPR (output) INTEGER array, dimension (2*M) +C The leading M elements contain information about the +C row interchanges performed for solving the system. +C Specifically, the i-th component of the solution is +C specified by IPR(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if a singular matrix was encountered. +C +C METHOD +C +C Gaussian elimination with partial pivoting is used. The rows of +C the matrix are not actually permuted, only their indices are +C interchanged in array IPR. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur metho... [truncated message content] |
From: <par...@us...> - 2010-01-10 17:51:21
|
Revision: 6731 http://octave.svn.sourceforge.net/octave/?rev=6731&view=rev Author: paramaniac Date: 2010-01-10 17:51:13 +0000 (Sun, 10 Jan 2010) Log Message: ----------- control-oo: fix bug in lyap/dlyap Modified Paths: -------------- trunk/octave-forge/extra/control-oo/inst/dlyap.m trunk/octave-forge/extra/control-oo/inst/lyap.m trunk/octave-forge/extra/control-oo/src/slsb03md.cc Modified: trunk/octave-forge/extra/control-oo/inst/dlyap.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/dlyap.m 2010-01-10 16:18:59 UTC (rev 6730) +++ trunk/octave-forge/extra/control-oo/inst/dlyap.m 2010-01-10 17:51:13 UTC (rev 6731) @@ -36,7 +36,7 @@ function x = dlyap (a, b, c) - if (nargin == 2) + if (nargin == 2) # Lyapunov equation na = issquare (a); nb = issquare (b); @@ -53,10 +53,12 @@ error ("lyap: a and b must be of identical size"); endif - x = slsb03md (a, -b, true); # AXA' - X = -B + [x, scale] = slsb03md (a, -b, true); # AXA' - X = -B - elseif (nargin == 3) + x *= scale; + elseif (nargin == 3) # Sylvester equation + n = issquare (a); m = issquare (b); [crows, ccols] = size (c); Modified: trunk/octave-forge/extra/control-oo/inst/lyap.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/lyap.m 2010-01-10 16:18:59 UTC (rev 6730) +++ trunk/octave-forge/extra/control-oo/inst/lyap.m 2010-01-10 17:51:13 UTC (rev 6731) @@ -36,7 +36,7 @@ function x = lyap (a, b, c) - if (nargin == 2) + if (nargin == 2) # Lyapunov equation na = issquare (a); nb = issquare (b); @@ -53,9 +53,11 @@ error ("lyap: a and b must be of identical size"); endif - x = slsb03md (a, -b, false); # AX + XA' = -B + [x, scale] = slsb03md (a, -b, false); # AX + XA' = -B - elseif (nargin == 3) + x *= scale; + + elseif (nargin == 3) # Sylvester equation n = issquare (a); m = issquare (b); Modified: trunk/octave-forge/extra/control-oo/src/slsb03md.cc =================================================================== --- trunk/octave-forge/extra/control-oo/src/slsb03md.cc 2010-01-10 16:18:59 UTC (rev 6730) +++ trunk/octave-forge/extra/control-oo/src/slsb03md.cc 2010-01-10 17:51:13 UTC (rev 6731) @@ -136,6 +136,7 @@ // return values retval(0) = c; + retval(1) = octave_value (scale); } return retval; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <par...@us...> - 2010-01-11 16:18:59
|
Revision: 6744 http://octave.svn.sourceforge.net/octave/?rev=6744&view=rev Author: paramaniac Date: 2010-01-11 16:18:25 +0000 (Mon, 11 Jan 2010) Log Message: ----------- control-oo: add support for generalized Lyapunov equations Modified Paths: -------------- trunk/octave-forge/extra/control-oo/inst/dlyap.m trunk/octave-forge/extra/control-oo/inst/lyap.m trunk/octave-forge/extra/control-oo/src/Makefile Added Paths: ----------- trunk/octave-forge/extra/control-oo/src/MB01RW.f trunk/octave-forge/extra/control-oo/src/MB02UU.f trunk/octave-forge/extra/control-oo/src/MB02UV.f trunk/octave-forge/extra/control-oo/src/SG03AD.f trunk/octave-forge/extra/control-oo/src/SG03AX.f trunk/octave-forge/extra/control-oo/src/SG03AY.f trunk/octave-forge/extra/control-oo/src/slsg03ad.cc Modified: trunk/octave-forge/extra/control-oo/inst/dlyap.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/dlyap.m 2010-01-11 11:28:08 UTC (rev 6743) +++ trunk/octave-forge/extra/control-oo/inst/dlyap.m 2010-01-11 16:18:25 UTC (rev 6744) @@ -81,9 +81,40 @@ x = slsb04qd (-a, b, c); # AXB' - X = -C - case 4 - error ("dlyap: case not implemented yet"); + case 4 # generalized Lyapunov equation + + if (! isempty (c)) + print_usage (); + endif + + na = issquare (a); + nb = issquare (b); + ne = issquare (e); + + if (! na) + error ("lyap: a must be square"); + endif + + if (! nb) + error ("lyap: b must be square"); + endif + + if (! ne) + error ("lyap: e must be square"); + endif + + if (! ((na == nb)) && (na == ne)) + error ("lyap: a, b, e not conformal"); + endif + + if (! issymmetric (b)) + error ("lyap: b must be symmetric"); + endif + [x, scale] = slsg03ad (a, e, -b, true); # AXA' - EXE' = -B + + x /= scale; # 0 < scale <= 1 + otherwise print_usage (); Modified: trunk/octave-forge/extra/control-oo/inst/lyap.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/lyap.m 2010-01-11 11:28:08 UTC (rev 6743) +++ trunk/octave-forge/extra/control-oo/inst/lyap.m 2010-01-11 16:18:25 UTC (rev 6744) @@ -81,9 +81,40 @@ x = slsb04md (a, b, -c); # AX + XB = -C - case 4 - error ("lyap: case not implemented yet"); + case 4 # generalized Lyapunov equation + + if (! isempty (c)) + print_usage (); + endif + + na = issquare (a); + nb = issquare (b); + ne = issquare (e); + + if (! na) + error ("lyap: a must be square"); + endif + + if (! nb) + error ("lyap: b must be square"); + endif + + if (! ne) + error ("lyap: e must be square"); + endif + + if (! ((na == nb)) && (na == ne)) + error ("lyap: a, b, e not conformal"); + endif + + if (! issymmetric (b)) + error ("lyap: b must be symmetric"); + endif + [x, scale] = slsg03ad (a, e, -b, false); # AXE' + EXA' = -B + + x /= scale; # 0 < scale <= 1 + otherwise print_usage (); @@ -121,3 +152,26 @@ %! 4.5257 -0.4389]; %! %!assert (X, X_exp, 1e-4); + +## Generalized Lyapunov +%!shared X, X_exp +%! A = [ 3.0 1.0 1.0 +%! 1.0 3.0 0.0 +%! 1.0 0.0 2.0]; +%! +%! E = [ 1.0 3.0 0.0 +%! 3.0 2.0 1.0 +%! 1.0 0.0 1.0]; +%! +%! B = [-64.0 -73.0 -28.0 +%! -73.0 -70.0 -25.0 +%! -28.0 -25.0 -18.0]; +%! +%! X = lyap (A', -B, [], E'); +%! +%! X_exp = [-2.0000 -1.0000 0.0000 +%! -1.0000 -3.0000 -1.0000 +%! 0.0000 -1.0000 -3.0000]; +%! +%!assert (X, X_exp, 1e-4); + Added: trunk/octave-forge/extra/control-oo/src/MB01RW.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/MB01RW.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/MB01RW.f 2010-01-11 16:18:25 UTC (rev 6744) @@ -0,0 +1,249 @@ + SUBROUTINE MB01RW( UPLO, TRANS, M, N, A, LDA, Z, LDZ, DWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To compute the transformation of the symmetric matrix A by the +C matrix Z in the form +C +C A := op(Z)*A*op(Z)', +C +C where op(Z) is either Z or its transpose, Z'. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Specifies whether the upper or lower triangle of A +C is stored: +C = 'U': Upper triangle of A is stored; +C = 'L': Lower triangle of A is stored. +C +C TRANS CHARACTER*1 +C Specifies whether op(Z) is Z or its transpose Z': +C = 'N': op(Z) = Z; +C = 'T': op(Z) = Z'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the resulting symmetric matrix op(Z)*A*op(Z)' +C and the number of rows of the matrix Z, if TRANS = 'N', +C or the number of columns of the matrix Z, if TRANS = 'T'. +C M >= 0. +C +C N (input) INTEGER +C The order of the symmetric matrix A and the number of +C columns of the matrix Z, if TRANS = 'N', or the number of +C rows of the matrix Z, if TRANS = 'T'. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA,MAX(M,N)) +C On entry, the leading N-by-N upper or lower triangular +C part of this array must contain the upper (UPLO = 'U') +C or lower (UPLO = 'L') triangular part of the symmetric +C matrix A. +C On exit, the leading M-by-M upper or lower triangular +C part of this array contains the upper (UPLO = 'U') or +C lower (UPLO = 'L') triangular part of the symmetric +C matrix op(Z)*A*op(Z)'. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,M,N). +C +C Z (input) DOUBLE PRECISION array, dimension (LDQ,K) +C where K = N if TRANS = 'N' and K = M if TRANS = 'T'. +C The leading M-by-N part, if TRANS = 'N', or N-by-M part, +C if TRANS = 'T', of this array contains the matrix Z. +C +C LDZ INTEGER +C The leading dimension of the array Z. +C LDZ >= MAX(1,M) if TRANS = 'N' and +C LDZ >= MAX(1,N) if TRANS = 'T'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C FURTHER COMMENTS +C +C This is a simpler, BLAS 2 version for MB01RD. +C +C CONTRIBUTOR +C +C A. Varga, DLR, Feb. 1995. +C +C REVISIONS +C +C April 1998 (T. Penzl). +C Sep. 1998 (V. Sima). +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER TRANS, UPLO + INTEGER INFO, LDA, LDZ, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL NOTTRA, UPPER + INTEGER I, J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable Statements +C + NOTTRA = LSAME( TRANS, 'N' ) + UPPER = LSAME( UPLO, 'U' ) +C + INFO = 0 + IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L') ) ) THEN + INFO = -1 + ELSE IF( .NOT.( NOTTRA .OR. LSAME( TRANS, 'T') ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M, N ) ) THEN + INFO = -6 + ELSE IF( ( NOTTRA .AND. LDZ.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.NOTTRA .AND. LDZ.LT.MAX( 1, N ) ) ) THEN + INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB01RW', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + IF ( NOTTRA ) THEN +C +C Compute Z*A*Z'. +C + IF ( UPPER ) THEN +C +C Compute Z*A in A (M-by-N). +C + DO 10 J = 1, N + CALL DCOPY( J-1, A(1,J), 1, DWORK, 1 ) + CALL DCOPY( N-J+1, A(J,J), LDA, DWORK(J), 1 ) + CALL DGEMV( TRANS, M, N, ONE, Z, LDZ, DWORK, 1, ZERO, + $ A(1,J), 1 ) + 10 CONTINUE +C +C Compute A*Z' in the upper triangular part of A. +C + DO 20 I = 1, M + CALL DCOPY( N, A(I,1), LDA, DWORK, 1 ) + CALL DGEMV( TRANS, M-I+1, N, ONE, Z(I,1), LDZ, DWORK, 1, + $ ZERO, A(I,I), LDA ) + 20 CONTINUE +C + ELSE +C +C Compute A*Z' in A (N-by-M). +C + DO 30 I = 1, N + CALL DCOPY( I-1, A(I,1), LDA, DWORK, 1 ) + CALL DCOPY( N-I+1, A(I,I), 1, DWORK(I), 1 ) + CALL DGEMV( TRANS, M, N, ONE, Z, LDZ, DWORK, 1, ZERO, + $ A(I,1), LDA ) + 30 CONTINUE +C +C Compute Z*A in the lower triangular part of A. +C + DO 40 J = 1, M + CALL DCOPY( N, A(1,J), 1, DWORK, 1 ) + CALL DGEMV( TRANS, M-J+1, N, ONE, Z(J,1), LDZ, DWORK, 1, + $ ZERO, A(J,J), 1 ) + 40 CONTINUE +C + END IF + ELSE +C +C Compute Z'*A*Z. +C + IF ( UPPER ) THEN +C +C Compute Z'*A in A (M-by-N). +C + DO 50 J = 1, N + CALL DCOPY( J-1, A(1,J), 1, DWORK, 1 ) + CALL DCOPY( N-J+1, A(J,J), LDA, DWORK(J), 1 ) + CALL DGEMV( TRANS, N, M, ONE, Z, LDZ, DWORK, 1, ZERO, + $ A(1,J), 1 ) + 50 CONTINUE +C +C Compute A*Z in the upper triangular part of A. +C + DO 60 I = 1, M + CALL DCOPY( N, A(I,1), LDA, DWORK, 1 ) + CALL DGEMV( TRANS, N, M-I+1, ONE, Z(1,I), LDZ, DWORK, 1, + $ ZERO, A(I,I), LDA ) + 60 CONTINUE +C + ELSE +C +C Compute A*Z in A (N-by-M). +C + DO 70 I = 1, N + CALL DCOPY( I-1, A(I,1), LDA, DWORK, 1 ) + CALL DCOPY( N-I+1, A(I,I), 1, DWORK(I), 1 ) + CALL DGEMV( TRANS, N, M, ONE, Z, LDZ, DWORK, 1, ZERO, + $ A(I,1), LDA ) + 70 CONTINUE +C +C Compute Z'*A in the lower triangular part of A. +C + DO 80 J = 1, M + CALL DCOPY( N, A(1,J), 1, DWORK, 1 ) + CALL DGEMV( TRANS, N, M-J+1, ONE, Z(1,J), LDZ, DWORK, 1, + $ ZERO, A(J,J), 1 ) + 80 CONTINUE +C + END IF + END IF +C + RETURN +C *** Last line of MB01RW *** + END Added: trunk/octave-forge/extra/control-oo/src/MB02UU.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/MB02UU.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/MB02UU.f 2010-01-11 16:18:25 UTC (rev 6744) @@ -0,0 +1,162 @@ + SUBROUTINE MB02UU( N, A, LDA, RHS, IPIV, JPIV, SCALE ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To solve for x in A * x = scale * RHS, using the LU factorization +C of the N-by-N matrix A computed by SLICOT Library routine MB02UV. +C The factorization has the form A = P * L * U * Q, where P and Q +C are permutation matrices, L is unit lower triangular and U is +C upper triangular. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. +C +C A (input) DOUBLE PRECISION array, dimension (LDA, N) +C The leading N-by-N part of this array must contain +C the LU part of the factorization of the matrix A computed +C by SLICOT Library routine MB02UV: A = P * L * U * Q. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1, N). +C +C RHS (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the right hand side +C of the system. +C On exit, this array contains the solution of the system. +C +C IPIV (input) INTEGER array, dimension (N) +C The pivot indices; for 1 <= i <= N, row i of the +C matrix has been interchanged with row IPIV(i). +C +C JPIV (input) INTEGER array, dimension (N) +C The pivot indices; for 1 <= j <= N, column j of the +C matrix has been interchanged with column JPIV(j). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, chosen 0 < SCALE <= 1 to prevent +C overflow in the solution. +C +C FURTHER COMMENTS +C +C In the interest of speed, this routine does not check the input +C for errors. It should only be used if the order of the matrix A +C is very small. +C +C CONTRIBUTOR +C +C Bo Kagstrom and P. Poromaa, Univ. of Umea, Sweden, Nov. 1993. +C +C REVISIONS +C +C April 1998 (T. Penzl). +C Sep. 1998 (V. Sima). +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TWO + PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) +C .. Scalar Arguments .. + INTEGER LDA, N + DOUBLE PRECISION SCALE +C .. Array Arguments .. + INTEGER IPIV( * ), JPIV( * ) + DOUBLE PRECISION A( LDA, * ), RHS( * ) +C .. Local Scalars .. + INTEGER I, IP, J + DOUBLE PRECISION BIGNUM, EPS, FACTOR, SMLNUM, TEMP +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, IDAMAX +C .. External Subroutines .. + EXTERNAL DAXPY, DLABAD, DSCAL +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX +C .. Executable Statements .. +C +C Set constants to control owerflow. +C + EPS = DLAMCH( 'Precision' ) + SMLNUM = DLAMCH( 'Safe minimum' ) / EPS + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C +C Apply permutations IPIV to RHS. +C + DO 20 I = 1, N - 1 + IP = IPIV(I) + IF ( IP.NE.I ) THEN + TEMP = RHS(I) + RHS(I) = RHS(IP) + RHS(IP) = TEMP + ENDIF + 20 CONTINUE +C +C Solve for L part. +C + DO 40 I = 1, N - 1 + CALL DAXPY( N-I, -RHS(I), A(I+1, I), 1, RHS(I+1), 1 ) + 40 CONTINUE +C +C Solve for U part. +C +C Check for scaling. +C + FACTOR = TWO * DBLE( N ) + I = 1 + 60 CONTINUE + IF ( ( FACTOR * SMLNUM ) * ABS( RHS(I) ) .LE. ABS( A(I, I) ) ) + $ THEN + I = I + 1 + IF ( I .LE. N ) GO TO 60 + SCALE = ONE + ELSE + SCALE = ( ONE / FACTOR ) / ABS( RHS( IDAMAX( N, RHS, 1 ) ) ) + CALL DSCAL( N, SCALE, RHS, 1 ) + END IF +C + DO 100 I = N, 1, -1 + TEMP = ONE / A(I, I) + RHS(I) = RHS(I) * TEMP + DO 80 J = I + 1, N + RHS(I) = RHS(I) - RHS(J) * ( A(I, J) * TEMP ) + 80 CONTINUE + 100 CONTINUE +C +C Apply permutations JPIV to the solution (RHS). +C + DO 120 I = N - 1, 1, -1 + IP = JPIV(I) + IF ( IP.NE.I ) THEN + TEMP = RHS(I) + RHS(I) = RHS(IP) + RHS(IP) = TEMP + ENDIF + 120 CONTINUE +C + RETURN +C *** Last line of MB02UU *** + END Added: trunk/octave-forge/extra/control-oo/src/MB02UV.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/MB02UV.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/MB02UV.f 2010-01-11 16:18:25 UTC (rev 6744) @@ -0,0 +1,195 @@ + SUBROUTINE MB02UV( N, A, LDA, IPIV, JPIV, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To compute an LU factorization, using complete pivoting, of the +C N-by-N matrix A. The factorization has the form A = P * L * U * Q, +C where P and Q are permutation matrices, L is lower triangular with +C unit diagonal elements and U is upper triangular. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA, N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A to be factored. +C On exit, the leading N-by-N part of this array contains +C the factors L and U from the factorization A = P*L*U*Q; +C the unit diagonal elements of L are not stored. If U(k, k) +C appears to be less than SMIN, U(k, k) is given the value +C of SMIN, giving a nonsingular perturbed system. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1, N). +C +C IPIV (output) INTEGER array, dimension (N) +C The pivot indices; for 1 <= i <= N, row i of the +C matrix has been interchanged with row IPIV(i). +C +C JPIV (output) INTEGER array, dimension (N) +C The pivot indices; for 1 <= j <= N, column j of the +C matrix has been interchanged with column JPIV(j). +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C = k: U(k, k) is likely to produce owerflow if one tries +C to solve for x in Ax = b. So U is perturbed to get +C a nonsingular system. This is a warning. +C +C FURTHER COMMENTS +C +C In the interests of speed, this routine does not check the input +C for errors. It should only be used to factorize matrices A of +C very small order. +C +C CONTRIBUTOR +C +C Bo Kagstrom and Peter Poromaa, Univ. of Umea, Sweden, Nov. 1993. +C +C REVISIONS +C +C April 1998 (T. Penzl). +C Sep. 1998 (V. Sima). +C March 1999 (V. Sima). +C March 2004 (V. Sima). +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, N +C .. Array Arguments .. + INTEGER IPIV( * ), JPIV( * ) + DOUBLE PRECISION A( LDA, * ) +C .. Local Scalars .. + INTEGER I, IP, IPV, JP, JPV + DOUBLE PRECISION BIGNUM, EPS, SMIN, SMLNUM, XMAX +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. External Subroutines .. + EXTERNAL DGER, DLABAD, DSCAL, DSWAP +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. Executable Statements .. +C +C Set constants to control owerflow. + + INFO = 0 + EPS = DLAMCH( 'Precision' ) + SMLNUM = DLAMCH( 'Safe minimum' ) / EPS + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C +C Find max element in matrix A. +C + IPV = 1 + JPV = 1 + XMAX = ZERO + DO 40 JP = 1, N + DO 20 IP = 1, N + IF ( ABS( A(IP, JP) ) .GT. XMAX ) THEN + XMAX = ABS( A(IP, JP) ) + IPV = IP + JPV = JP + ENDIF + 20 CONTINUE + 40 CONTINUE + SMIN = MAX( EPS * XMAX, SMLNUM ) +C +C Swap rows. +C + IF ( IPV .NE. 1 ) CALL DSWAP( N, A(IPV, 1), LDA, A(1, 1), LDA ) + IPIV(1) = IPV +C +C Swap columns. +C + IF ( JPV .NE. 1 ) CALL DSWAP( N, A(1, JPV), 1, A(1, 1), 1 ) + JPIV(1) = JPV +C +C Check for singularity. +C + IF ( ABS( A(1, 1) ) .LT. SMIN ) THEN + INFO = 1 + A(1, 1) = SMIN + ENDIF + IF ( N.GT.1 ) THEN + CALL DSCAL( N - 1, ONE / A(1, 1), A(2, 1), 1 ) + CALL DGER( N - 1, N - 1, -ONE, A(2, 1), 1, A(1, 2), LDA, + $ A(2, 2), LDA ) + ENDIF +C +C Factorize the rest of A with complete pivoting. +C Set pivots less than SMIN to SMIN. +C + DO 100 I = 2, N - 1 +C +C Find max element in remaining matrix. +C + IPV = I + JPV = I + XMAX = ZERO + DO 80 JP = I, N + DO 60 IP = I, N + IF ( ABS( A(IP, JP) ) .GT. XMAX ) THEN + XMAX = ABS( A(IP, JP) ) + IPV = IP + JPV = JP + ENDIF + 60 CONTINUE + 80 CONTINUE +C +C Swap rows. +C + IF ( IPV .NE. I ) CALL DSWAP( N, A(IPV, 1), LDA, A(I, 1), LDA ) + IPIV(I) = IPV +C +C Swap columns. +C + IF ( JPV .NE. I ) CALL DSWAP( N, A(1, JPV), 1, A(1, I), 1 ) + JPIV(I) = JPV +C +C Check for almost singularity. +C + IF ( ABS( A(I, I) ) .LT. SMIN ) THEN + INFO = I + A(I, I) = SMIN + ENDIF + CALL DSCAL( N - I, ONE / A(I, I), A(I + 1, I), 1 ) + CALL DGER( N - I, N - I, -ONE, A(I + 1, I), 1, A(I, I + 1), + $ LDA, A(I + 1, I + 1), LDA ) + 100 CONTINUE + IF ( ABS( A(N, N) ) .LT. SMIN ) THEN + INFO = N + A(N, N) = SMIN + ENDIF +C + RETURN +C *** Last line of MB02UV *** + END Modified: trunk/octave-forge/extra/control-oo/src/Makefile =================================================================== --- trunk/octave-forge/extra/control-oo/src/Makefile 2010-01-11 11:28:08 UTC (rev 6743) +++ trunk/octave-forge/extra/control-oo/src/Makefile 2010-01-11 16:18:25 UTC (rev 6744) @@ -1,6 +1,6 @@ all: slab08nd.oct slab13dd.oct slsb10hd.oct slsb10ed.oct slab13bd.oct \ slsb01bd.oct slsb10fd.oct slsb10dd.oct slsb03md.oct slsb04md.oct \ - slsb04qd.oct + slsb04qd.oct slsg03ad.oct # transmission zeros of state-space models slab08nd.oct: slab08nd.cc @@ -85,5 +85,11 @@ mkoctfile slsb04qd.cc \ SB04QD.f SB04QU.f SB04QY.f SB04MW.f SB04QR.f +# generalized Lyapunov equations +slsg03ad.oct: slsg03ad.cc + mkoctfile slsg03ad.cc \ + SG03AD.f MB01RW.f MB01RD.f SG03AX.f SG03AY.f \ + MB02UU.f MB02UV.f + clean: rm *.o core octave-core *.oct *~ Added: trunk/octave-forge/extra/control-oo/src/SG03AD.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/SG03AD.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/SG03AD.f 2010-01-11 16:18:25 UTC (rev 6744) @@ -0,0 +1,639 @@ + SUBROUTINE SG03AD( DICO, JOB, FACT, TRANS, UPLO, N, A, LDA, E, + $ LDE, Q, LDQ, Z, LDZ, X, LDX, SCALE, SEP, FERR, + $ ALPHAR, ALPHAI, BETA, IWORK, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To solve for X either the generalized continuous-time Lyapunov +C equation +C +C T T +C op(A) X op(E) + op(E) X op(A) = SCALE * Y, (1) +C +C or the generalized discrete-time Lyapunov equation +C +C T T +C op(A) X op(A) - op(E) X op(E) = SCALE * Y, (2) +C +C where op(M) is either M or M**T for M = A, E and the right hand +C side Y is symmetric. A, E, Y, and the solution X are N-by-N +C matrices. SCALE is an output scale factor, set to avoid overflow +C in X. +C +C Estimates of the separation and the relative forward error norm +C are provided. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies which type of the equation is considered: +C = 'C': Continuous-time equation (1); +C = 'D': Discrete-time equation (2). +C +C JOB CHARACTER*1 +C Specifies if the solution is to be computed and if the +C separation is to be estimated: +C = 'X': Compute the solution only; +C = 'S': Estimate the separation only; +C = 'B': Compute the solution and estimate the separation. +C +C FACT CHARACTER*1 +C Specifies whether the generalized real Schur +C factorization of the pencil A - lambda * E is supplied +C on entry or not: +C = 'N': Factorization is not supplied; +C = 'F': Factorization is supplied. +C +C TRANS CHARACTER*1 +C Specifies whether the transposed equation is to be solved +C or not: +C = 'N': op(A) = A, op(E) = E; +C = 'T': op(A) = A**T, op(E) = E**T. +C +C UPLO CHARACTER*1 +C Specifies whether the lower or the upper triangle of the +C array X is needed on input: +C = 'L': Only the lower triangle is needed on input; +C = 'U': Only the upper triangle is needed on input. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, if FACT = 'F', then the leading N-by-N upper +C Hessenberg part of this array must contain the +C generalized Schur factor A_s of the matrix A (see +C definition (3) in section METHOD). A_s must be an upper +C quasitriangular matrix. The elements below the upper +C Hessenberg part of the array A are not referenced. +C If FACT = 'N', then the leading N-by-N part of this +C array must contain the matrix A. +C On exit, the leading N-by-N part of this array contains +C the generalized Schur factor A_s of the matrix A. (A_s is +C an upper quasitriangular matrix.) +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, if FACT = 'F', then the leading N-by-N upper +C triangular part of this array must contain the +C generalized Schur factor E_s of the matrix E (see +C definition (4) in section METHOD). The elements below the +C upper triangular part of the array E are not referenced. +C If FACT = 'N', then the leading N-by-N part of this +C array must contain the coefficient matrix E of the +C equation. +C On exit, the leading N-by-N part of this array contains +C the generalized Schur factor E_s of the matrix E. (E_s is +C an upper triangular matrix.) +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, if FACT = 'F', then the leading N-by-N part of +C this array must contain the orthogonal matrix Q from +C the generalized Schur factorization (see definitions (3) +C and (4) in section METHOD). +C If FACT = 'N', Q need not be set on entry. +C On exit, the leading N-by-N part of this array contains +C the orthogonal matrix Q from the generalized Schur +C factorization. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= MAX(1,N). +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C On entry, if FACT = 'F', then the leading N-by-N part of +C this array must contain the orthogonal matrix Z from +C the generalized Schur factorization (see definitions (3) +C and (4) in section METHOD). +C If FACT = 'N', Z need not be set on entry. +C On exit, the leading N-by-N part of this array contains +C the orthogonal matrix Z from the generalized Schur +C factorization. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= MAX(1,N). +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, if JOB = 'B' or 'X', then the leading N-by-N +C part of this array must contain the right hand side matrix +C Y of the equation. Either the lower or the upper +C triangular part of this array is needed (see mode +C parameter UPLO). +C If JOB = 'S', X is not referenced. +C On exit, if JOB = 'B' or 'X', and INFO = 0, 3, or 4, then +C the leading N-by-N part of this array contains the +C solution matrix X of the equation. +C If JOB = 'S', X is not referenced. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor set to avoid overflow in X. +C (0 < SCALE <= 1) +C +C SEP (output) DOUBLE PRECISION +C If JOB = 'S' or JOB = 'B', and INFO = 0, 3, or 4, then +C SEP contains an estimate of the separation of the +C Lyapunov operator. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'B', and INFO = 0, 3, or 4, then FERR contains an +C estimated forward error bound for the solution X. If XTRUE +C is the true solution, FERR estimates the relative error +C in the computed solution, measured in the Frobenius norm: +C norm(X - XTRUE) / norm(XTRUE) +C +C ALPHAR (output) DOUBLE PRECISION array, dimension (N) +C ALPHAI (output) DOUBLE PRECISION array, dimension (N) +C BETA (output) DOUBLE PRECISION array, dimension (N) +C If FACT = 'N' and INFO = 0, 3, or 4, then +C (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, are the +C eigenvalues of the matrix pencil A - lambda * E. +C If FACT = 'F', ALPHAR, ALPHAI, and BETA are not +C referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N**2) +C IWORK is not referenced if JOB = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. The following table +C contains the minimal work space requirements depending +C on the choice of JOB and FACT. +C +C JOB FACT | LDWORK +C -------------------+------------------- +C 'X' 'F' | MAX(1,N) +C 'X' 'N' | MAX(1,4*N) +C 'B', 'S' 'F' | MAX(1,2*N**2) +C 'B', 'S' 'N' | MAX(1,2*N**2,4*N) +C +C For optimum performance, LDWORK should be larger. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: FACT = 'F' and the matrix contained in the upper +C Hessenberg part of the array A is not in upper +C quasitriangular form; +C = 2: FACT = 'N' and the pencil A - lambda * E cannot be +C reduced to generalized Schur form: LAPACK routine +C DGEGS has failed to converge; +C = 3: DICO = 'D' and the pencil A - lambda * E has a +C pair of reciprocal eigenvalues. That is, lambda_i = +C 1/lambda_j for some i and j, where lambda_i and +C lambda_j are eigenvalues of A - lambda * E. Hence, +C equation (2) is singular; perturbed values were +C used to solve the equation (but the matrices A and +C E are unchanged); +C = 4: DICO = 'C' and the pencil A - lambda * E has a +C degenerate pair of eigenvalues. That is, lambda_i = +C -lambda_j for some i and j, where lambda_i and +C lambda_j are eigenvalues of A - lambda * E. Hence, +C equation (1) is singular; perturbed values were +C used to solve the equation (but the matrices A and +C E are unchanged). +C +C METHOD +C +C A straightforward generalization [3] of the method proposed by +C Bartels and Stewart [1] is utilized to solve (1) or (2). +C +C First the pencil A - lambda * E is reduced to real generalized +C Schur form A_s - lambda * E_s by means of orthogonal +C transformations (QZ-algorithm): +C +C A_s = Q**T * A * Z (upper quasitriangular) (3) +C +C E_s = Q**T * E * Z (upper triangular). (4) +C +C If FACT = 'F', this step is omitted. Assuming SCALE = 1 and +C defining +C +C ( Z**T * Y * Z : TRANS = 'N' +C Y_s = < +C ( Q**T * Y * Q : TRANS = 'T' +C +C +C ( Q**T * X * Q if TRANS = 'N' +C X_s = < (5) +C ( Z**T * X * Z if TRANS = 'T' +C +C leads to the reduced Lyapunov equation +C +C T T +C op(A_s) X_s op(E_s) + op(E_s) X_s op(A_s) = Y_s, (6) +C +C or +C T T +C op(A_s) X_s op(A_s) - op(E_s) X_s op(E_s) = Y_s, (7) +C +C which are equivalent to (1) or (2), respectively. The solution X_s +C of (6) or (7) is computed via block back substitution (if TRANS = +C 'N') or block forward substitution (if TRANS = 'T'), where the +C block order is at most 2. (See [1] and [3] for details.) +C Equation (5) yields the solution matrix X. +C +C For fast computation the estimates of the separation and the +C forward error are gained from (6) or (7) rather than (1) or +C (2), respectively. We consider (6) and (7) as special cases of the +C generalized Sylvester equation +C +C R * X * S + U * X * V = Y, (8) +C +C whose separation is defined as follows +C +C sep = sep(R,S,U,V) = min || R * X * S + U * X * V || . +C ||X|| = 1 F +C F +C +C Equation (8) is equivalent to the system of linear equations +C +C K * vec(X) = (kron(S**T,R) + kron(V**T,U)) * vec(X) = vec(Y), +C +C where kron is the Kronecker product of two matrices and vec +C is the mapping that stacks the columns of a matrix. If K is +C nonsingular then +C +C sep = 1 / ||K**(-1)|| . +C 2 +C +C We estimate ||K**(-1)|| by a method devised by Higham [2]. Note +C that this method yields an estimation for the 1-norm but we use it +C as an approximation for the 2-norm. Estimates for the forward +C error norm are provided by +C +C FERR = 2 * EPS * ||A_s|| * ||E_s|| / sep +C F F +C +C in the continuous-time case (1) and +C +C FERR = EPS * ( ||A_s|| **2 + ||E_s|| **2 ) / sep +C F F +C +C in the discrete-time case (2). +C The reciprocal condition number, RCOND, of the Lyapunov equation +C can be estimated by FERR/EPS. +C +C REFERENCES +C +C [1] Bartels, R.H., Stewart, G.W. +C Solution of the equation A X + X B = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Higham, N.J. +C FORTRAN codes for estimating the one-norm of a real or complex +C matrix, with applications to condition estimation. +C A.C.M. Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, 1988. +C +C [3] Penzl, T. +C Numerical solution of generalized Lyapunov equations. +C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. +C +C NUMERICAL ASPECTS +C +C The number of flops required by the routine is given by the +C following table. Note that we count a single floating point +C arithmetic operation as one flop. c is an integer number of modest +C size (say 4 or 5). +C +C | FACT = 'F' FACT = 'N' +C -----------+------------------------------------------ +C JOB = 'B' | (26+8*c)/3 * N**3 (224+8*c)/3 * N**3 +C JOB = 'S' | 8*c/3 * N**3 (198+8*c)/3 * N**3 +C JOB = 'X' | 26/3 * N**3 224/3 * N**3 +C +C The algorithm is backward stable if the eigenvalues of the pencil +C A - lambda * E are real. Otherwise, linear systems of order at +C most 4 are involved into the computation. These systems are solved +C by Gauss elimination with complete pivoting. The loss of stability +C of the Gauss elimination with complete pivoting is rarely +C encountered in practice. +C +C The Lyapunov equation may be very ill-conditioned. In particular, +C if DICO = 'D' and the pencil A - lambda * E has a pair of almost +C reciprocal eigenvalues, or DICO = 'C' and the pencil has an almost +C degenerate pair of eigenvalues, then the Lyapunov equation will be +C ill-conditioned. Perturbed values were used to solve the equation. +C Ill-conditioning can be detected by a very small value of the +C reciprocal condition number RCOND. +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C Dec. 1998 (V. Sima). +C +C KEYWORDS +C +C Lyapunov equation +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TWO, ZERO + PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER DICO, FACT, JOB, TRANS, UPLO + DOUBLE PRECISION FERR, SCALE, SEP + INTEGER INFO, LDA, LDE, LDQ, LDWORK, LDX, LDZ, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), BETA(*), + $ DWORK(*), E(LDE,*), Q(LDQ,*), X(LDX,*), + $ Z(LDZ,*) + INTEGER IWORK(*) +C .. Local Scalars .. + CHARACTER ETRANS + DOUBLE PRECISION EST, EPS, NORMA, NORME, SCALE1 + INTEGER I, INFO1, KASE, MINWRK, OPTWRK + LOGICAL ISDISC, ISFACT, ISTRAN, ISUPPR, WANTBH, WANTSP, + $ WANTX +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DNRM2 + LOGICAL LSAME + EXTERNAL DLAMCH, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEGS, DLACON, MB01RD, MB01RW, SG03AX, + $ SG03AY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C .. Executable Statements .. +C +C Decode input parameters. +C + ISDISC = LSAME( DICO, 'D' ) + WANTX = LSAME( JOB, 'X' ) + WANTSP = LSAME( JOB, 'S' ) + WANTBH = LSAME( JOB, 'B' ) + ISFACT = LSAME( FACT, 'F' ) + ISTRAN = LSAME( TRANS, 'T' ) + ISUPPR = LSAME( UPLO, 'U' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( ISDISC .OR. LSAME( DICO, 'C' ) ) ) THEN + INFO = -1 + ELSEIF ( .NOT.( WANTX .OR. WANTSP .OR. WANTBH ) ) THEN + INFO = -2 + ELSEIF ( .NOT.( ISFACT .OR. LSAME( FACT, 'N' ) ) ) THEN + INFO = -3 + ELSEIF ( .NOT.( ISTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN + INFO = -4 + ELSEIF ( .NOT.( ISUPPR .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -5 + ELSEIF ( N .LT. 0 ) THEN + INFO = -6 + ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN + INFO = -8 + ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN + INFO = -10 + ELSEIF ( LDQ .LT. MAX( 1, N ) ) THEN + INFO = -12 + ELSEIF ( LDZ .LT. MAX( 1, N ) ) THEN + INFO = -14 + ELSEIF ( LDX .LT. MAX( 1, N ) ) THEN + INFO = -16 + ELSE + INFO = 0 + END IF + IF ( INFO .EQ. 0 ) THEN +C +C Compute minimal workspace. +C + IF ( WANTX ) THEN + IF ( ISFACT ) THEN + MINWRK = MAX( N, 1 ) + ELSE + MINWRK = MAX( 4*N, 1 ) + END IF + ELSE + IF ( ISFACT ) THEN + MINWRK = MAX( 2*N*N, 1 ) + ELSE + MINWRK = MAX( 2*N*N, 4*N, 1 ) + END IF + END IF + IF ( MINWRK .GT. LDWORK ) THEN + INFO = -25 + END IF + END IF + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SG03AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N .EQ. 0 ) THEN + SCALE = ONE + IF ( .NOT.WANTX ) SEP = ZERO + IF ( WANTBH ) FERR = ZERO + DWORK(1) = ONE + RETURN + END IF +C + IF ( ISFACT ) THEN +C +C Make sure the upper Hessenberg part of A is quasitriangular. +C + DO 20 I = 1, N-2 + IF ( A(I+1,I).NE.ZERO .AND. A(I+2,I+1).NE.ZERO ) THEN + INFO = 1 + RETURN + END IF + 20 CONTINUE + END IF +C + IF ( .NOT.ISFACT ) THEN +C +C Reduce A - lambda * E to generalized Schur form. +C +C A := Q**T * A * Z (upper quasitriangular) +C E := Q**T * E * Z (upper triangular) +C +C ( Workspace: >= MAX(1,4*N) ) +C + CALL DGEGS( 'Vectors', 'Vectors', N, A, LDA, E, LDE, ALPHAR, + $ ALPHAI, BETA, Q, LDQ, Z, LDZ, DWORK, LDWORK, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + INFO = 2 + RETURN + END IF + OPTWRK = INT( DWORK(1) ) + ELSE + OPTWRK = MINWRK + END IF +C + IF ( WANTBH .OR. WANTX ) THEN +C +C Transform right hand side. +C +C X := Z**T * X * Z or X := Q**T * X * Q +C +C Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2. +C +C ( Workspace: >= N ) +C + IF ( LDWORK .LT. N*N ) THEN + IF ( ISTRAN ) THEN + CALL MB01RW( UPLO, 'Transpose', N, N, X, LDX, Q, LDQ, + $ DWORK, INFO1 ) + ELSE + CALL MB01RW( UPLO, 'Transpose', N, N, X, LDX, Z, LDZ, + $ DWORK, INFO1 ) + END IF + ELSE + IF ( ISTRAN ) THEN + CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, + $ Q, LDQ, X, LDX, DWORK, LDWORK, INFO ) + ELSE + CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, + $ Z, LDZ, X, LDX, DWORK, LDWORK, INFO ) + END IF + END IF + IF ( .NOT.ISUPPR ) THEN + DO 40 I = 1, N-1 + CALL DCOPY( N-I, X(I+1,I), 1, X(I,I+1), LDX ) + 40 CONTINUE + END IF + OPTWRK = MAX( OPTWRK, N*N ) +C +C Solve reduced generalized Lyapunov equation. +C + IF ( ISDISC ) THEN + CALL SG03AX( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO1) + IF ( INFO1 .NE. 0 ) + $ INFO = 3 + ELSE + CALL SG03AY( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO1) + IF ( INFO1 .NE. 0 ) + $ INFO = 4 + END IF +C +C Transform the solution matrix back. +C +C X := Q * X * Q**T or X := Z * X * Z**T. +C +C Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2. +C +C ( Workspace: >= N ) +C + IF ( LDWORK .LT. N*N ) THEN + IF ( ISTRAN ) THEN + CALL MB01RW( 'Upper', 'NoTranspose', N, N, X, LDX, Z, + $ LDZ, DWORK, INFO1 ) + ELSE + CALL MB01RW( 'Upper', 'NoTranspose', N, N, X, LDX, Q, + $ LDQ, DWORK, INFO1 ) + END IF + ELSE + IF ( ISTRAN ) THEN + CALL MB01RD( 'Upper', 'NoTranspose', N, N, ZERO, ONE, X, + $ LDX, Z, LDZ, X, LDX, DWORK, LDWORK, INFO ) + ELSE + CALL MB01RD( 'Upper', 'NoTranspose', N, N, ZERO, ONE, X, + $ LDX, Q, LDQ, X, LDX, DWORK, LDWORK, INFO ) + END IF + END IF + DO 60 I = 1, N-1 + CALL DCOPY( N-I, X(I,I+1), LDX, X(I+1,I), 1 ) + 60 CONTINUE + END IF +C + IF ( WANTBH .OR. WANTSP ) THEN +C +C Estimate the 1-norm of the inverse Kronecker product matrix +C belonging to the reduced generalized Lyapunov equation. +C +C ( Workspace: 2*N*N ) +C + EST = ZERO + KASE = 0 + 80 CONTINUE + CALL DLACON( N*N, DWORK(N*N+1), DWORK, IWORK, EST, KASE ) + IF ( KASE .NE. 0 ) THEN + IF ( ( KASE.EQ.1 .AND. .NOT.ISTRAN ) .OR. + $ ( KASE.NE.1 .AND. ISTRAN ) ) THEN + ETRANS = 'N' + ELSE + ETRANS = 'T' + END IF + IF ( ISDISC ) THEN + CALL SG03AX( ETRANS, N, A, LDA, E, LDE, DWORK, N, SCALE1, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 3 + ELSE + CALL SG03AY( ETRANS, N, A, LDA, E, LDE, DWORK, N, SCALE1, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 4 + END IF + GOTO 80 + END IF + SEP = SCALE1/EST + END IF +C +C Estimate the relative forward error. +C +C ( Workspace: 2*N ) +C + IF ( WANTBH ) THEN + EPS = DLAMCH( 'Precision' ) + DO 100 I = 1, N + DWORK(I) = DNRM2( MIN( I+1, N ), A(1,I), 1 ) + DWORK(N+I) = DNRM2( I, E(1,I), 1 ) + 100 CONTINUE + NORMA = DNRM2( N, DWORK, 1 ) + NORME = DNRM2( N, DWORK(N+1), 1 ) + IF ( ISDISC ) THEN + FERR = ( NORMA**2 + NORME**2 )*EPS/SEP + ELSE + FERR = TWO*NORMA*NORME*EPS/SEP + END IF + END IF +C + DWORK(1) = DBLE( MAX( OPTWRK, MINWRK ) ) + RETURN +C *** Last line of SG03AD *** + END Added: trunk/octave-forge/extra/control-oo/src/SG03AX.f =================================================================== --- trunk/octave-forge/extra/control-oo/src/SG03AX.f (rev 0) +++ trunk/octave-forge/extra/control-oo/src/SG03AX.f 2010-01-11 16:18:25 UTC (rev 6744) @@ -0,0 +1,687 @@ + SUBROUTINE SG03AX( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C <http://www.gnu.org/licenses/>. +C +C PURPOSE +C +C To solve for X either the reduced generalized discrete-time +C Lyapunov equation +C +C T T +C A * X * A - E * X * E = SCALE * Y (1) +C +C or +C +C T T +C A * X * A - E * X * E = SCALE * Y (2) +C +C where the right hand side Y is symmetric. A, E, Y, and the +C solution X are N-by-N matrices. The pencil A - lambda * E must be +C in generalized Schur form (A upper quasitriangular, E upper +C triangular). SCALE is an output scale factor, set to avoid +C overflow in X. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANS CHARACTER*1 +C Specifies whether the transposed equation is to be solved +C or not: +C = 'N': Solve equation (1); +C = 'T': Solve equation (2). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N upper Hessenberg part of this array +C must contain the quasitriangular matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N upper triangular part of this array +C must contain the matrix E. +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= MAX(1,N). +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, the leading N-by-N part of this array must +C contain the right hand side matrix Y of the equation. Only +C the upper triangular part of this matrix need be given. +C On exit, the leading N-by-N part of this array contains +C the solution matrix X of the equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor set to avoid overflow in X. +C (0 < SCALE <= 1) +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: equation is (almost) singular to working precision; +C perturbed values were used to solve the equation +C (but the matrices A and E are unchanged). +C +C METHOD +C +C The solution X of (1) or (2) is computed via block back +C substitution or block forward substitution, respectively. (See +C [1] and [2] for details.) +C +C REFERENCES +C +C [1] Bartels, R.H., Stewart, G.W. +C Solution of the equation A X + X B = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Penzl, T. +C Numerical solution of generalized Lyapunov equations. +C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. +C +C NUMERICAL ASPECTS +C +C 8/3 * N**3 flops are required by the routine. Note that we count a +C single floating point arithmetic operation as one flop. +C +C The algorithm is backward stable if the eigenvalues of the pencil +C A - lambda * E are real. Otherwise, linear systems of order at +C most 4 are involved into the computation. These systems are solved +C by Gauss elimination with complete pivoting. The loss of stability +C of the Gauss elimination with complete pivoting is rarely +C encountered in practice. +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C Dec. 1998 (V. Sima). +C +C KEYWORDS +C +C Lyapunov equation +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION MONE, ONE, ZERO + PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER TRANS + DOUBLE PRECISION SCALE + INTEGER INFO, LDA, LDE, LDX, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), E(LDE,*), X(LDX,*) +C .. Local Scalars .. + DOUBLE PRECISION AK11, AK12, AK21, AK22, AL11, AL12, AL21, AL22, + $ EK11, EK12, EK22, EL11, EL12, EL22, SCALE1 + INTEGER DIMMAT, I, INFO1, KB, KH, KL, LB, LH, LL + LOGICAL NOTRNS +C .. Local Arrays .. + DOUBLE PRECISION MAT(4,4), RHS(4), TM(2,2) + INTEGER PIV1(4), PIV2(4) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DSCAL, MB02UU, + $ MB02UV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Decode input parameter. +C + NOTRNS = LSAME( TRANS, 'N' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN + INFO = -1 + ELSEIF ( N .LT. 0 ) THEN + INFO = -2 + ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN + INFO = -4 + ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN + INFO = -6 + ELSEIF ( LDX .LT. MAX( 1, N ) ) THEN + INFO = -8 + ELSE + INFO = 0 + END IF + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SG03AX', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF ( N .EQ. 0 ) RETURN +C + IF ( NOTRNS ) THEN +C +C Solve equation (1). +C +C Outer Loop. Compute block row X(KL:KH,:). KB denotes the number +C of rows in this block row. +C + KL = 0 + KB = 1 +C WHILE ( KL+KB .LE. N ) DO + 20 IF ( KL+KB .LE. N ) THEN + KL = KL + KB + IF ( KL .EQ. N ) THEN + KB = 1 + ELSE + IF ( A(KL+1,KL) .NE. ZERO ) THEN + KB = 2 + ELSE + KB = 1 + END IF + END IF + KH = KL + KB - 1 +C +C Copy elements of solution already known by symmetry. +C +C X(KL:KH,1:KL-1) = X(1:KL-1,KL:KH)' +C + IF ( KL .GT. 1 ) THEN + DO 40 I = KL, KH + CALL DCOPY( KL-1, X(1,I), 1, X(I,1), LDX ) + 40 CONTINUE + END IF +C +C Inner Loop. Compute block X(KL:KH,LL:LH). LB denotes the +C number of columns in this block. +C + LL = KL - 1 + LB = 1 +C WHILE ( LL+LB .LE. N ) DO + 60 IF ( LL+LB .LE. N ) THEN + LL = LL + LB + IF ( LL .EQ. N ) THEN + LB = 1 + ELSE + IF ( A(LL+1,LL) .NE. ZERO ) THEN + LB = 2 + ELSE + LB = 1 + END IF + END IF + LH = LL + LB - 1 +C +C Update right hand sides (I). +C +C X(KL:LH,LL:LH) = X(KL:LH,LL:LH) - +C A(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*A(1:LL-1,LL:LH)) +C +C X(KL:LH,LL:LH) = X(KL:LH,LL:LH) + +C E(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*E(1:LL-1,LL:LH)) +C + IF ( LL .GT. 1 ) THEN + CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), LDX, + $ A(1,LL), LDA, ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', LH-KL+1, LB, KB, MONE, A(KL,KL), + $ LDA, TM, 2, ONE, X(KL,LL), LDX ) + CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), + $ LDX, E(1,LL), LDE, ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', LH-KH+1, LB, KB, ONE, E(KL,KH), + $ LDE, TM, 2, ONE, X(KH,LL), LDX ) + IF ( KB .EQ. 2 ) CALL DAXPY( LB, E(KL,KL), TM, 2, + $ X(KL,LL), LDX ) + END IF +C +C Solve small Sylvester equations of order at most (2,2). +C + IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN +C + DIMMAT = 1 +C + MAT(1,1) = A(LL,LL)*A(KL,KL) - E(LL,LL)*E(KL,KL) +C + RHS(1) = X(KL,LL) +C + ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN +C + DIMMAT = 2 +C + AK11 = A(KL,KL) + AK12 = A(KL,KH) + AK21 = A(KH,KL) + AK22 = A(KH,KH) +C + AL11 = A(LL,LL) +C + EK11 = E(KL,KL) + EK12 = E(KL,KH) + EK22 = E(KH,KH) +C + EL11 = E(LL,LL) +C + MAT(1,1) = AL11*AK11 - EL11*EK11 + MAT(1,2) = AL11*AK21 + MAT(2,1) = AL11*AK12 - EL11*EK12 + MAT(2,2) = AL11*AK22 - EL11*EK22 +C + RHS(1) = X(KL,LL) + RHS(2) = X(KH,LL) +C + ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN +C + DIMMAT = 2 +C + AK11 = A(KL,KL) +C + AL11 = A(LL,LL) + AL12 = A(LL,LH) + AL21 = A(LH,LL) + ... [truncated message content] |
From: <par...@us...> - 2010-01-18 13:28:13
|
Revision: 6786 http://octave.svn.sourceforge.net/octave/?rev=6786&view=rev Author: paramaniac Date: 2010-01-18 12:14:21 +0000 (Mon, 18 Jan 2010) Log Message: ----------- control-oo: add example model of a BMW engine Modified Paths: -------------- trunk/octave-forge/extra/control-oo/INDEX Added Paths: ----------- trunk/octave-forge/extra/control-oo/inst/BMWengine.m Modified: trunk/octave-forge/extra/control-oo/INDEX =================================================================== --- trunk/octave-forge/extra/control-oo/INDEX 2010-01-17 19:55:49 UTC (rev 6785) +++ trunk/octave-forge/extra/control-oo/INDEX 2010-01-18 12:14:21 UTC (rev 6786) @@ -1,5 +1,6 @@ control >> Control Theory Examples and Demos + BMWengine Boeing707 optiPID WestlandLynx Added: trunk/octave-forge/extra/control-oo/inst/BMWengine.m =================================================================== --- trunk/octave-forge/extra/control-oo/inst/BMWengine.m (rev 0) +++ trunk/octave-forge/extra/control-oo/inst/BMWengine.m 2010-01-18 12:14:21 UTC (rev 6786) @@ -0,0 +1,110 @@ +## -*- texinfo -*- +## @deftypefn{Function File} {@var{sys} =} BMWengine () +## @deftypefnx{Function File} {@var{sys} =} BMWengine (@var{"scaled"}) +## @deftypefnx{Function File} {@var{sys} =} BMWengine (@var{"unscaled"}) +## Model of the BMW 4-cylinder engine at ETH Zurich's control laboratory. +## @example +## @group +## OPERATING POINT +## Drosselklappenstellung alpha_DK = 10.3 Grad +## Saugrohrdruck p_s = 0.48 bar +## Motordrehzahl n = 860 U/min +## Lambda-Messwert lambda = 1.000 +## Relativer Wandfilminhalt nu = 1 +## +## INPUTS +## U_1 Sollsignal Drosselklappenstellung [Grad] +## U_2 Relative Einspritzmenge [-] +## U_3 Zuendzeitpunkt [Grad KW] +## M_L Lastdrehmoment [Nm] +## +## STATES +## X_1 Drosselklappenstellung [Grad] +## X_2 Saugrohrdruck [bar] +## X_3 Motordrehzahl [U/min] +## X_4 Messwert Lamba-Sonde [-] +## X_5 Relativer Wandfilminhalt [-] +## +## OUTPUTS +## Y_1 Motordrehzahl [U/min] +## Y_2 Messwert Lambda-Sonde [-] +## +## SCALING +## U_1N, X_1N 1 Grad +## U_2N, X_4N, X_5N, Y_2N 0.05 +## U_3N 1.6 Grad KW +## X_2N 0.05 bar +## X_3N, Y_1N 200 U/min +## @end group +## @end example +## @end deftypefn + +## Author: Lukas Reichlin <luk...@gm...> +## Created: January 2010 +## Version: 0.1 + +## TODO: translate German terminology + +function sys = BMWengine (flg = "scaled") + + if (nargin > 1) + print_usage (); + endif + + switch (tolower (flg)) + case "unscaled" ## Linearisiertes Modell, nicht skaliert + + Apu = [ -40.0000 0 0 0 0 + 0.1683 -2.9471 -0.0016 0 0 + 26.6088 920.3932 -0.1756 0 259.1700 + -0.5852 14.1941 0.0061 -5.7000 -5.7000 + 0.6600 -1.1732 -0.0052 0 -15.0000 ]; + + Bpu = [ 40.0000 0 0 + 0 0 0 + 0 181.4190 1.5646 + 0 -3.9900 0 + 0 4.5000 0 ]; + + Bdpu = [ 0 + 0 + -15.9000 + 0 + 0 ]; + + Cpu = [ 0 0 1 0 0 + 0 0 0 1 0 ]; + + sys = ss (Apu, [Bpu, Bdpu], Cpu); + + case "scaled" ## Skaliertes Zustandsraummodell + + Ap = [ -40.0000 0 0 0 0 + 3.3659 -2.9471 -6.5157 0 0 + 0.1330 0.2301 -0.1756 0 0.0648 + -11.7043 14.1941 24.3930 -5.7000 -5.7000 + 13.2003 -1.1732 -20.9844 0 -15.0000 ]; + + Bp = [ 40.0000 0 0 + 0 0 0 + 0 0.0454 0.0125 + 0 -3.9900 0 + 0 4.5000 0 ]; + + Bdp = [ 0 + 0 + -1.5900 + 0 + 0 ]; + + Cp = [ 0 0 1 0 0 + 0 0 0 1 0 ]; + + sys = ss (Ap, [Bp, Bdp], Cp); + + otherwise + print_usage (); + + endswitch + +endfunction \ No newline at end of file This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |